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, kcDataDecl, tcConDecls, mkRecSelBinds,
11 checkValidTyCon, dataDeclChecks, badFamInstDecl
14 #include "HsVersions.h"
27 import TysWiredIn ( unitTy )
33 import MkCore ( rEC_SEL_ERROR_ID )
47 import Unique ( mkBuiltinUnique )
56 %************************************************************************
58 \subsection{Type checking for type and class declarations}
60 %************************************************************************
64 tcTyAndClassDecls :: ModDetails
65 -> [[LTyClDecl Name]] -- Mutually-recursive groups in dependency order
66 -> TcM (TcGblEnv, -- Input env extended by types and classes
67 -- and their implicit Ids,DataCons
68 HsValBinds Name, -- Renamed bindings for record selectors
69 [Id], -- Default method ids
70 [LTyClDecl Name]) -- Kind-checked declarations
71 -- Fails if there are any errors
73 tcTyAndClassDecls boot_details decls_s
74 = checkNoErrs $ -- The code recovers internally, but if anything gave rise to
75 -- an error we'd better stop now, to avoid a cascade
76 do { let tyclds_s = map (filterOut (isFamInstDecl . unLoc)) decls_s
77 -- Remove family instance decls altogether
78 -- They are dealt with by TcInstDcls
80 ; tyclss <- fixM $ \ rec_tyclss ->
81 tcExtendRecEnv (zipRecTyClss tyclds_s rec_tyclss) $
82 -- We must populate the environment with the loop-tied
83 -- T's right away (even before kind checking), because
84 -- the kind checker may "fault in" some type constructors
85 -- that recursively mention T
87 do { -- Kind-check in dependency order
88 -- See Note [Kind checking for type and class decls]
89 kc_decls <- kcTyClDecls tyclds_s
91 -- And now build the TyCons/Classes
92 ; let rec_flags = calcRecFlags boot_details rec_tyclss
93 ; concatMapM (tcTyClDecl rec_flags) kc_decls }
95 ; tcExtendGlobalEnv tyclss $ do
96 { -- Perform the validity check
97 -- We can do this now because we are done with the recursive knot
98 traceTc "ready for validity check" empty
99 ; mapM_ (addLocM checkValidTyCl) (concat tyclds_s)
100 ; traceTc "done" empty
102 -- Add the implicit things;
103 -- we want them in the environment because
104 -- they may be mentioned in interface files
105 -- NB: All associated types and their implicit things will be added a
106 -- second time here. This doesn't matter as the definitions are
108 ; let { implicit_things = concatMap implicitTyThings tyclss
109 ; rec_sel_binds = mkRecSelBinds tyclss
110 ; dm_ids = mkDefaultMethodIds tyclss }
112 ; env <- tcExtendGlobalEnv implicit_things getGblEnv
113 -- We need the kind-checked declarations later, so we return them
115 ; kc_decls <- kcTyClDecls tyclds_s
116 ; return (env, rec_sel_binds, dm_ids, kc_decls) } }
118 zipRecTyClss :: [[LTyClDecl Name]]
119 -> [TyThing] -- Knot-tied
121 -- Build a name-TyThing mapping for the things bound by decls
122 -- being careful not to look at the [TyThing]
123 -- The TyThings in the result list must have a visible ATyCon/AClass,
124 -- because typechecking types (in, say, tcTyClDecl) looks at this outer constructor
125 zipRecTyClss decls_s rec_things
126 = [ get decl | decls <- decls_s, L _ decl <- flattenATs decls ]
128 rec_type_env :: TypeEnv
129 rec_type_env = mkTypeEnv rec_things
131 get :: TyClDecl Name -> (Name, TyThing)
132 get (ClassDecl {tcdLName = L _ name}) = (name, AClass cl)
134 Just (AClass cl) = lookupTypeEnv rec_type_env name
135 get decl = (name, ATyCon tc)
138 Just (ATyCon tc) = lookupTypeEnv rec_type_env name
142 %************************************************************************
146 %************************************************************************
148 Note [Kind checking for type and class decls]
149 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
150 Kind checking is done thus:
152 1. Make up a kind variable for each parameter of the *data* type,
153 and class, decls, and extend the kind environment (which is in
156 2. Dependency-analyse the type *synonyms* (which must be non-recursive),
157 and kind-check them in dependency order. Extend the kind envt.
159 3. Kind check the data type and class decls
161 Synonyms are treated differently to data type and classes,
162 because a type synonym can be an unboxed type
164 and a kind variable can't unify with UnboxedTypeKind
165 So we infer their kinds in dependency order
167 We need to kind check all types in the mutually recursive group
168 before we know the kind of the type variables. For example:
171 op :: D b => a -> b -> b
174 bop :: (Monad c) => ...
176 Here, the kind of the locally-polymorphic type variable "b"
177 depends on *all the uses of class D*. For example, the use of
178 Monad c in bop's type signature means that D must have kind Type->Type.
180 However type synonyms work differently. They can have kinds which don't
181 just involve (->) and *:
182 type R = Int# -- Kind #
183 type S a = Array# a -- Kind * -> #
184 type T a b = (# a,b #) -- Kind * -> * -> (# a,b #)
185 So we must infer their kinds from their right-hand sides *first* and then
186 use them, whereas for the mutually recursive data types D we bring into
187 scope kind bindings D -> k, where k is a kind variable, and do inference.
191 This treatment of type synonyms only applies to Haskell 98-style synonyms.
192 General type functions can be recursive, and hence, appear in `alg_decls'.
194 The kind of a type family is solely determinded by its kind signature;
195 hence, only kind signatures participate in the construction of the initial
196 kind environment (as constructed by `getInitialKind'). In fact, we ignore
197 instances of families altogether in the following. However, we need to
198 include the kinds of associated families into the construction of the
199 initial kind environment. (This is handled by `allDecls').
203 kcTyClDecls :: [[LTyClDecl Name]] -> TcM [LTyClDecl Name]
204 kcTyClDecls [] = return []
205 kcTyClDecls (decls : decls_s) = do { (tcl_env, kc_decls1) <- kcTyClDecls1 decls
206 ; kc_decls2 <- setLclEnv tcl_env (kcTyClDecls decls_s)
207 ; return (kc_decls1 ++ kc_decls2) }
209 kcTyClDecls1 :: [LTyClDecl Name] -> TcM (TcLclEnv, [LTyClDecl Name])
211 = do { -- Omit instances of type families; they are handled together
212 -- with the *heads* of class instances
213 ; let (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls
214 alg_at_decls = flattenATs alg_decls
217 ; traceTc "tcTyAndCl" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls))
219 -- First check for cyclic classes
220 ; checkClassCycleErrs alg_decls
222 -- Kind checking; see Note [Kind checking for type and class decls]
223 ; alg_kinds <- mapM getInitialKind alg_at_decls
224 ; tcExtendKindEnv alg_kinds $ do
226 { (kc_syn_decls, tcl_env) <- kcSynDecls (calcSynCycles syn_decls)
227 ; setLclEnv tcl_env $ do
228 { kc_alg_decls <- mapM (wrapLocM kcTyClDecl) alg_decls
230 -- Kind checking done for this group, so zonk the kind variables
231 -- See Note [Kind checking for type and class decls]
232 ; mapM_ (zonkTcKindToKind . snd) alg_kinds
234 ; return (tcl_env, kc_syn_decls ++ kc_alg_decls) } } }
236 flattenATs :: [LTyClDecl Name] -> [LTyClDecl Name]
237 flattenATs decls = concatMap flatten decls
239 flatten decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats
240 flatten decl = [decl]
242 getInitialKind :: LTyClDecl Name -> TcM (Name, TcKind)
243 -- Only for data type, class, and indexed type declarations
244 -- Get as much info as possible from the data, class, or indexed type decl,
245 -- so as to maximise usefulness of error messages
246 getInitialKind (L _ decl)
247 = do { arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl)
248 ; res_kind <- mk_res_kind decl
249 ; return (tcdName decl, mkArrowKinds arg_kinds res_kind) }
251 mk_arg_kind (UserTyVar _ _) = newKindVar
252 mk_arg_kind (KindedTyVar _ kind) = return kind
254 mk_res_kind (TyFamily { tcdKind = Just kind }) = return kind
255 mk_res_kind (TyData { tcdKindSig = Just kind }) = return kind
256 -- On GADT-style declarations we allow a kind signature
257 -- data T :: *->* where { ... }
258 mk_res_kind _ = return liftedTypeKind
262 kcSynDecls :: [SCC (LTyClDecl Name)]
263 -> TcM ([LTyClDecl Name], -- Kind-annotated decls
264 TcLclEnv) -- Kind bindings
266 = do { tcl_env <- getLclEnv; return ([], tcl_env) }
267 kcSynDecls (group : groups)
268 = do { (decl, nk) <- kcSynDecl group
269 ; (decls, tcl_env) <- tcExtendKindEnv [nk] (kcSynDecls groups)
270 ; return (decl:decls, tcl_env) }
273 kcSynDecl :: SCC (LTyClDecl Name)
274 -> TcM (LTyClDecl Name, -- Kind-annotated decls
275 (Name,TcKind)) -- Kind bindings
276 kcSynDecl (AcyclicSCC (L loc decl))
277 = tcAddDeclCtxt decl $
278 kcHsTyVars (tcdTyVars decl) (\ k_tvs ->
279 do { traceTc "kcd1" (ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl))
280 <+> brackets (ppr k_tvs))
281 ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl)
282 ; traceTc "kcd2" (ppr (unLoc (tcdLName decl)))
283 ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs
284 ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }),
285 (unLoc (tcdLName decl), tc_kind)) })
287 kcSynDecl (CyclicSCC decls)
288 = do { recSynErr decls; failM } -- Fail here to avoid error cascade
289 -- of out-of-scope tycons
291 ------------------------------------------------------------------------
292 kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
293 -- Not used for type synonyms (see kcSynDecl)
295 kcTyClDecl decl@(TyData {})
296 = ASSERT( not . isFamInstDecl $ decl ) -- must not be a family instance
297 kcTyClDeclBody decl $
300 kcTyClDecl decl@(TyFamily {})
301 = kcFamilyDecl [] decl -- the empty list signals a toplevel decl
303 kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
304 = kcTyClDeclBody decl $ \ tvs' ->
305 do { ctxt' <- kcHsContext ctxt
306 ; ats' <- mapM (wrapLocM (kcFamilyDecl tvs')) ats
307 ; sigs' <- mapM (wrapLocM kc_sig) sigs
308 ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs',
311 kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
312 ; return (TypeSig nm op_ty') }
313 kc_sig (GenericSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
314 ; return (GenericSig nm op_ty') }
315 kc_sig other_sig = return other_sig
317 kcTyClDecl decl@(ForeignType {})
320 kcTyClDecl (TySynonym {}) = panic "kcTyClDecl TySynonym"
322 kcTyClDeclBody :: TyClDecl Name
323 -> ([LHsTyVarBndr Name] -> TcM a)
325 -- getInitialKind has made a suitably-shaped kind for the type or class
326 -- Unpack it, and attribute those kinds to the type variables
327 -- Extend the env with bindings for the tyvars, taken from
328 -- the kind of the tycon/class. Give it to the thing inside, and
329 -- check the result kind matches
330 kcTyClDeclBody decl thing_inside
331 = tcAddDeclCtxt decl $
332 do { tc_ty_thing <- tcLookupLocated (tcdLName decl)
333 ; let tc_kind = case tc_ty_thing of
335 _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing)
336 (kinds, _) = splitKindFunTys tc_kind
337 hs_tvs = tcdTyVars decl
338 kinded_tvs = ASSERT( length kinds >= length hs_tvs )
339 zipWith add_kind hs_tvs kinds
340 ; tcExtendKindEnvTvs kinded_tvs thing_inside }
342 add_kind (L loc (UserTyVar n _)) k = L loc (UserTyVar n k)
343 add_kind (L loc (KindedTyVar n _)) k = L loc (KindedTyVar n k)
345 -- Kind check a data declaration, assuming that we already extended the
346 -- kind environment with the type variables of the left-hand side (these
347 -- kinded type variables are also passed as the second parameter).
349 kcDataDecl :: TyClDecl Name -> [LHsTyVarBndr Name] -> TcM (TyClDecl Name)
350 kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
352 = do { ctxt' <- kcHsContext ctxt
353 ; cons' <- mapM (wrapLocM kc_con_decl) cons
354 ; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) }
356 -- doc comments are typechecked to Nothing here
357 kc_con_decl con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs
358 , con_cxt = ex_ctxt, con_details = details, con_res = res })
359 = addErrCtxt (dataConCtxt name) $
360 kcHsTyVars ex_tvs $ \ex_tvs' -> do
361 do { ex_ctxt' <- kcHsContext ex_ctxt
362 ; details' <- kc_con_details details
363 ; res' <- case res of
364 ResTyH98 -> return ResTyH98
365 ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
366 ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt'
367 , con_details = details', con_res = res' }) }
369 kc_con_details (PrefixCon btys)
370 = do { btys' <- mapM kc_larg_ty btys
371 ; return (PrefixCon btys') }
372 kc_con_details (InfixCon bty1 bty2)
373 = do { bty1' <- kc_larg_ty bty1
374 ; bty2' <- kc_larg_ty bty2
375 ; return (InfixCon bty1' bty2') }
376 kc_con_details (RecCon fields)
377 = do { fields' <- mapM kc_field fields
378 ; return (RecCon fields') }
380 kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty
381 ; return (ConDeclField fld bty' d) }
383 kc_larg_ty bty = case new_or_data of
384 DataType -> kcHsSigType bty
385 NewType -> kcHsLiftedSigType bty
386 -- Can't allow an unlifted type for newtypes, because we're effectively
387 -- going to remove the constructor while coercing it to a lifted type.
388 -- And newtypes can't be bang'd
389 kcDataDecl d _ = pprPanic "kcDataDecl" (ppr d)
391 -- Kind check a family declaration or type family default declaration.
393 kcFamilyDecl :: [LHsTyVarBndr Name] -- tyvars of enclosing class decl if any
394 -> TyClDecl Name -> TcM (TyClDecl Name)
395 kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind})
396 = kcTyClDeclBody decl $ \tvs' ->
397 do { mapM_ unifyClassParmKinds tvs'
398 ; return (decl {tcdTyVars = tvs',
399 tcdKind = kind `mplus` Just liftedTypeKind})
400 -- default result kind is '*'
403 unifyClassParmKinds (L _ tv)
404 | (n,k) <- hsTyVarNameKind tv
405 , Just classParmKind <- lookup n classTyKinds
406 = unifyKind k classParmKind
407 | otherwise = return ()
408 classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs]
410 kcFamilyDecl _ (TySynonym {}) -- type family defaults
411 = panic "TcTyClsDecls.kcFamilyDecl: not implemented yet"
412 kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d)
416 %************************************************************************
418 \subsection{Type checking}
420 %************************************************************************
423 tcTyClDecl :: (Name -> RecFlag) -> LTyClDecl Name -> TcM [TyThing]
425 tcTyClDecl calc_isrec (L loc decl)
426 = setSrcSpan loc $ tcAddDeclCtxt decl $
427 tcTyClDecl1 NoParentTyCon calc_isrec decl
429 -- "type family" declarations
430 tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
431 tcTyClDecl1 parent _calc_isrec
432 (TyFamily {tcdFlavour = TypeFamily,
433 tcdLName = L _ tc_name, tcdTyVars = tvs,
434 tcdKind = Just kind}) -- NB: kind at latest added during kind checking
435 = tcTyVarBndrs tvs $ \ tvs' -> do
436 { traceTc "type family:" (ppr tc_name)
438 -- Check that we don't use families without -XTypeFamilies
439 ; idx_tys <- xoptM Opt_TypeFamilies
440 ; checkTc idx_tys $ badFamInstDecl tc_name
442 ; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent Nothing
443 ; return [ATyCon tycon]
446 -- "data family" declaration
447 tcTyClDecl1 parent _calc_isrec
448 (TyFamily {tcdFlavour = DataFamily,
449 tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind})
450 = tcTyVarBndrs tvs $ \ tvs' -> do
451 { traceTc "data family:" (ppr tc_name)
452 ; extra_tvs <- tcDataKindSig mb_kind
453 ; let final_tvs = tvs' ++ extra_tvs -- we may not need these
456 -- Check that we don't use families without -XTypeFamilies
457 ; idx_tys <- xoptM Opt_TypeFamilies
458 ; checkTc idx_tys $ badFamInstDecl tc_name
460 ; tycon <- buildAlgTyCon tc_name final_tvs []
461 DataFamilyTyCon Recursive True
463 ; return [ATyCon tycon]
467 tcTyClDecl1 _parent _calc_isrec
468 (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
469 = ASSERT( isNoParent _parent )
470 tcTyVarBndrs tvs $ \ tvs' -> do
471 { traceTc "tcd1" (ppr tc_name)
472 ; rhs_ty' <- tcHsKindedType rhs_ty
473 ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty')
474 (typeKind rhs_ty') NoParentTyCon Nothing
475 ; return [ATyCon tycon] }
477 -- "newtype" and "data"
478 -- NB: not used for newtype/data instances (whether associated or not)
479 tcTyClDecl1 _parent calc_isrec
480 (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
481 tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons})
482 = ASSERT( isNoParent _parent )
483 tcTyVarBndrs tvs $ \ tvs' -> do
484 { extra_tvs <- tcDataKindSig mb_ksig
485 ; let final_tvs = tvs' ++ extra_tvs
486 ; stupid_theta <- tcHsKindedContext ctxt
487 ; unbox_strict <- doptM Opt_UnboxStrictFields
488 ; kind_signatures <- xoptM Opt_KindSignatures
489 ; existential_ok <- xoptM Opt_ExistentialQuantification
490 ; gadt_ok <- xoptM Opt_GADTs
491 ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
492 ; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context
494 -- Check that we don't use kind signatures without Glasgow extensions
495 ; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name)
497 ; dataDeclChecks tc_name new_or_data stupid_theta cons
499 ; tycon <- fixM (\ tycon -> do
500 { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
501 ; data_cons <- tcConDecls unbox_strict ex_ok
502 tycon (final_tvs, res_ty) cons
504 if null cons && is_boot -- In a hs-boot file, empty cons means
505 then return AbstractTyCon -- "don't know"; hence Abstract
506 else case new_or_data of
507 DataType -> return (mkDataTyConRhs data_cons)
508 NewType -> ASSERT( not (null data_cons) )
509 mkNewTyConRhs tc_name tycon (head data_cons)
510 ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
511 (not h98_syntax) NoParentTyCon Nothing
513 ; return [ATyCon tycon]
516 is_rec = calc_isrec tc_name
517 h98_syntax = consUseH98Syntax cons
519 tcTyClDecl1 _parent calc_isrec
520 (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs,
521 tcdCtxt = ctxt, tcdMeths = meths,
522 tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} )
523 = ASSERT( isNoParent _parent )
524 tcTyVarBndrs tvs $ \ tvs' -> do
525 { ctxt' <- tcHsKindedContext ctxt
526 ; fds' <- mapM (addLocM tc_fundep) fundeps
527 ; sig_stuff <- tcClassSigs class_name sigs meths
528 ; clas <- fixM $ \ clas -> do
529 { let -- This little knot is just so we can get
530 -- hold of the name of the class TyCon, which we
531 -- need to look up its recursiveness
532 tycon_name = tyConName (classTyCon clas)
533 tc_isrec = calc_isrec tycon_name
534 ; atss' <- mapM (addLocM $ tcTyClDecl1 (AssocFamilyTyCon clas) (const Recursive)) ats
535 -- NB: 'ats' only contains "type family" and "data family"
536 -- declarations as well as type family defaults
537 ; buildClass False {- Must include unfoldings for selectors -}
538 class_name tvs' ctxt' fds' (concat atss')
540 ; return (AClass clas : map ATyCon (classATs clas))
541 -- NB: Order is important due to the call to `mkGlobalThings' when
542 -- tying the the type and class declaration type checking knot.
545 tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM tcLookupTyVar tvs1 ;
546 ; tvs2' <- mapM tcLookupTyVar tvs2 ;
547 ; return (tvs1', tvs2') }
550 (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
551 = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)]
553 tcTyClDecl1 _ _ d = pprPanic "tcTyClDecl1" (ppr d)
555 dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl Name] -> TcM ()
556 dataDeclChecks tc_name new_or_data stupid_theta cons
557 = do { -- Check that we don't use GADT syntax in H98 world
558 gadtSyntax_ok <- xoptM Opt_GADTSyntax
559 ; let h98_syntax = consUseH98Syntax cons
560 ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl tc_name)
562 -- Check that the stupid theta is empty for a GADT-style declaration
563 ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name)
565 -- Check that a newtype has exactly one constructor
566 -- Do this before checking for empty data decls, so that
567 -- we don't suggest -XEmptyDataDecls for newtypes
568 ; checkTc (new_or_data == DataType || isSingleton cons)
569 (newtypeConError tc_name (length cons))
571 -- Check that there's at least one condecl,
572 -- or else we're reading an hs-boot file, or -XEmptyDataDecls
573 ; empty_data_decls <- xoptM Opt_EmptyDataDecls
574 ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
575 ; checkTc (not (null cons) || empty_data_decls || is_boot)
576 (emptyConDeclsErr tc_name) }
578 -----------------------------------
579 tcConDecls :: Bool -> Bool -> TyCon -> ([TyVar], Type)
580 -> [LConDecl Name] -> TcM [DataCon]
581 tcConDecls unbox ex_ok rep_tycon res_tmpl cons
582 = mapM (addLocM (tcConDecl unbox ex_ok rep_tycon res_tmpl)) cons
584 tcConDecl :: Bool -- True <=> -funbox-strict_fields
585 -> Bool -- True <=> -XExistentialQuantificaton or -XGADTs
586 -> TyCon -- Representation tycon
587 -> ([TyVar], Type) -- Return type template (with its template tyvars)
591 tcConDecl unbox_strict existential_ok rep_tycon res_tmpl -- Data types
592 con@(ConDecl {con_name = name, con_qvars = tvs, con_cxt = ctxt
593 , con_details = details, con_res = res_ty })
594 = addErrCtxt (dataConCtxt name) $
595 tcTyVarBndrs tvs $ \ tvs' -> do
596 { ctxt' <- tcHsKindedContext ctxt
597 ; checkTc (existential_ok || conRepresentibleWithH98Syntax con)
598 (badExistential name)
599 ; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty
601 tc_datacon is_infix field_lbls btys
602 = do { (arg_tys, stricts) <- mapAndUnzipM (tcConArg unbox_strict) btys
603 ; buildDataCon (unLoc name) is_infix
605 univ_tvs ex_tvs eq_preds ctxt' arg_tys
607 -- NB: we put data_tc, the type constructor gotten from the
608 -- constructor type signature into the data constructor;
609 -- that way checkValidDataCon can complain if it's wrong.
612 PrefixCon btys -> tc_datacon False [] btys
613 InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2]
614 RecCon fields -> tc_datacon False field_names btys
616 field_names = map (unLoc . cd_fld_name) fields
617 btys = map cd_fld_type fields
621 -- data instance T (b,c) where
622 -- TI :: forall e. e -> T (e,e)
624 -- The representation tycon looks like this:
625 -- data :R7T b c where
626 -- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1
627 -- In this case orig_res_ty = T (e,e)
629 tcResultType :: ([TyVar], Type) -- Template for result type; e.g.
630 -- data instance T [a] b c = ...
631 -- gives template ([a,b,c], T [a] b c)
632 -> [TyVar] -- where MkT :: forall x y z. ...
634 -> TcM ([TyVar], -- Universal
635 [TyVar], -- Existential (distinct OccNames from univs)
636 [(TyVar,Type)], -- Equality predicates
637 Type) -- Typechecked return type
638 -- We don't check that the TyCon given in the ResTy is
639 -- the same as the parent tycon, becuase we are in the middle
640 -- of a recursive knot; so it's postponed until checkValidDataCon
642 tcResultType (tmpl_tvs, res_ty) dc_tvs ResTyH98
643 = return (tmpl_tvs, dc_tvs, [], res_ty)
644 -- In H98 syntax the dc_tvs are the existential ones
645 -- data T a b c = forall d e. MkT ...
646 -- The {a,b,c} are tc_tvs, and {d,e} are dc_tvs
648 tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty)
649 -- E.g. data T [a] b c where
650 -- MkT :: forall x y z. T [(x,y)] z z
652 -- Univ tyvars Eq-spec
656 -- Existentials are the leftover type vars: [x,y]
657 -- So we return ([a,b,z], [x,y], [a~(x,y),b~z], T [(x,y)] z z)
658 = do { res_ty' <- tcHsKindedType res_ty
659 ; let Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty'
661 -- /Lazily/ figure out the univ_tvs etc
662 -- Each univ_tv is either a dc_tv or a tmpl_tv
663 (univ_tvs, eq_spec) = foldr choose ([], []) tidy_tmpl_tvs
664 choose tmpl (univs, eqs)
665 | Just ty <- lookupTyVar subst tmpl
666 = case tcGetTyVar_maybe ty of
667 Just tv | not (tv `elem` univs)
669 _other -> (tmpl:univs, (tmpl,ty):eqs)
670 | otherwise = pprPanic "tcResultType" (ppr res_ty)
671 ex_tvs = dc_tvs `minusList` univ_tvs
673 ; return (univ_tvs, ex_tvs, eq_spec, res_ty') }
675 -- NB: tmpl_tvs and dc_tvs are distinct, but
676 -- we want them to be *visibly* distinct, both for
677 -- interface files and general confusion. So rename
678 -- the tc_tvs, since they are not used yet (no
679 -- consequential renaming needed)
680 (_, tidy_tmpl_tvs) = mapAccumL tidy_one init_occ_env tmpl_tvs
681 init_occ_env = initTidyOccEnv (map getOccName dc_tvs)
682 tidy_one env tv = (env', setTyVarName tv (tidyNameOcc name occ'))
685 (env', occ') = tidyOccName env (getOccName name)
687 consUseH98Syntax :: [LConDecl a] -> Bool
688 consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False
689 consUseH98Syntax _ = True
690 -- All constructors have same shape
692 conRepresentibleWithH98Syntax :: ConDecl Name -> Bool
693 conRepresentibleWithH98Syntax
694 (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyH98 })
695 = null tvs && null (unLoc ctxt)
696 conRepresentibleWithH98Syntax
697 (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyGADT (L _ t) })
698 = null (unLoc ctxt) && f t (map (hsTyVarName . unLoc) tvs)
699 where -- Each type variable should be used exactly once in the
700 -- result type, and the result type must just be the type
701 -- constructor applied to type variables
702 f (HsAppTy (L _ t1) (L _ (HsTyVar v2))) vs
703 = (v2 `elem` vs) && f t1 (delete v2 vs)
704 f (HsTyVar _) [] = True
708 tcConArg :: Bool -- True <=> -funbox-strict_fields
710 -> TcM (TcType, HsBang)
711 tcConArg unbox_strict bty
712 = do { arg_ty <- tcHsBangType bty
713 ; let bang = getBangStrictness bty
714 ; let strict_mark = chooseBoxingStrategy unbox_strict arg_ty bang
715 ; return (arg_ty, strict_mark) }
717 -- We attempt to unbox/unpack a strict field when either:
718 -- (i) The field is marked '!!', or
719 -- (ii) The field is marked '!', and the -funbox-strict-fields flag is on.
721 -- We have turned off unboxing of newtypes because coercions make unboxing
722 -- and reboxing more complicated
723 chooseBoxingStrategy :: Bool -> TcType -> HsBang -> HsBang
724 chooseBoxingStrategy unbox_strict_fields arg_ty bang
727 HsUnpack -> can_unbox HsUnpackFailed arg_ty
728 HsStrict | unbox_strict_fields -> can_unbox HsStrict arg_ty
729 | otherwise -> HsStrict
730 HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty)
731 -- Source code never has shtes
733 can_unbox :: HsBang -> TcType -> HsBang
734 -- Returns HsUnpack if we can unpack arg_ty
735 -- fail_bang if we know what arg_ty is but we can't unpack it
736 -- HsStrict if it's abstract, so we don't know whether or not we can unbox it
737 can_unbox fail_bang arg_ty
738 = case splitTyConApp_maybe arg_ty of
741 Just (arg_tycon, tycon_args)
742 | isAbstractTyCon arg_tycon -> HsStrict
743 -- See Note [Don't complain about UNPACK on abstract TyCons]
744 | not (isRecursiveTyCon arg_tycon) -- Note [Recusive unboxing]
745 , isProductTyCon arg_tycon
746 -- We can unbox if the type is a chain of newtypes
747 -- with a product tycon at the end
748 -> if isNewTyCon arg_tycon
749 then can_unbox fail_bang (newTyConInstRhs arg_tycon tycon_args)
752 | otherwise -> fail_bang
755 Note [Don't complain about UNPACK on abstract TyCons]
756 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
757 We are going to complain about UnpackFailed, but if we say
758 data T = MkT {-# UNPACK #-} !Wobble
759 and Wobble is a newtype imported from a module that was compiled
760 without optimisation, we don't want to complain. Because it might
761 be fine when optimsation is on. I think this happens when Haddock
762 is working over (say) GHC souce files.
764 Note [Recursive unboxing]
765 ~~~~~~~~~~~~~~~~~~~~~~~~~
766 Be careful not to try to unbox this!
768 But it's the *argument* type that matters. This is fine:
770 because Int is non-recursive.
773 %************************************************************************
777 %************************************************************************
779 Validity checking is done once the mutually-recursive knot has been
780 tied, so we can look at things freely.
783 checkClassCycleErrs :: [LTyClDecl Name] -> TcM ()
784 checkClassCycleErrs tyclss
788 = do { mapM_ recClsErr cls_cycles
789 ; failM } -- Give up now, because later checkValidTyCl
790 -- will loop if the synonym is recursive
792 cls_cycles = calcClassCycles tyclss
794 checkValidTyCl :: TyClDecl Name -> TcM ()
795 -- We do the validity check over declarations, rather than TyThings
796 -- only so that we can add a nice context with tcAddDeclCtxt
798 = tcAddDeclCtxt decl $
799 do { thing <- tcLookupLocatedGlobal (tcdLName decl)
800 ; traceTc "Validity of" (ppr thing)
802 ATyCon tc -> checkValidTyCon tc
803 AClass cl -> do { checkValidClass cl
804 ; mapM_ (addLocM checkValidTyCl) (tcdATs decl) }
805 _ -> panic "checkValidTyCl"
806 ; traceTc "Done validity of" (ppr thing)
809 -------------------------
810 -- For data types declared with record syntax, we require
811 -- that each constructor that has a field 'f'
812 -- (a) has the same result type
813 -- (b) has the same type for 'f'
814 -- module alpha conversion of the quantified type variables
815 -- of the constructor.
817 -- Note that we allow existentials to match becuase the
818 -- fields can never meet. E.g
820 -- T1 { f1 :: b, f2 :: a, f3 ::Int } :: T
821 -- T2 { f1 :: c, f2 :: c, f3 ::Int } :: T
822 -- Here we do not complain about f1,f2 because they are existential
824 checkValidTyCon :: TyCon -> TcM ()
827 = case synTyConRhs tc of
828 SynFamilyTyCon {} -> return ()
829 SynonymTyCon ty -> checkValidType syn_ctxt ty
831 = do -- Check the context on the data decl
832 checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)
834 -- Check arg types of data constructors
835 mapM_ (checkValidDataCon tc) data_cons
837 -- Check that fields with the same name share a type
838 mapM_ check_fields groups
841 syn_ctxt = TySynCtxt name
843 data_cons = tyConDataCons tc
845 groups = equivClasses cmp_fld (concatMap get_fields data_cons)
846 cmp_fld (f1,_) (f2,_) = f1 `compare` f2
847 get_fields con = dataConFieldLabels con `zip` repeat con
848 -- dataConFieldLabels may return the empty list, which is fine
850 -- See Note [GADT record selectors] in MkId.lhs
851 -- We must check (a) that the named field has the same
852 -- type in each constructor
853 -- (b) that those constructors have the same result type
855 -- However, the constructors may have differently named type variable
856 -- and (worse) we don't know how the correspond to each other. E.g.
857 -- C1 :: forall a b. { f :: a, g :: b } -> T a b
858 -- C2 :: forall d c. { f :: c, g :: c } -> T c d
860 -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's
861 -- result type against other candidates' types BOTH WAYS ROUND.
862 -- If they magically agrees, take the substitution and
863 -- apply them to the latter ones, and see if they match perfectly.
864 check_fields ((label, con1) : other_fields)
865 -- These fields all have the same name, but are from
866 -- different constructors in the data type
867 = recoverM (return ()) $ mapM_ checkOne other_fields
868 -- Check that all the fields in the group have the same type
869 -- NB: this check assumes that all the constructors of a given
870 -- data type use the same type variables
872 (tvs1, _, _, res1) = dataConSig con1
874 fty1 = dataConFieldType con1 label
876 checkOne (_, con2) -- Do it bothways to ensure they are structurally identical
877 = do { checkFieldCompat label con1 con2 ts1 res1 res2 fty1 fty2
878 ; checkFieldCompat label con2 con1 ts2 res2 res1 fty2 fty1 }
880 (tvs2, _, _, res2) = dataConSig con2
882 fty2 = dataConFieldType con2 label
883 check_fields [] = panic "checkValidTyCon/check_fields []"
885 checkFieldCompat :: Name -> DataCon -> DataCon -> TyVarSet
886 -> Type -> Type -> Type -> Type -> TcM ()
887 checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2
888 = do { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)
889 ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }
891 mb_subst1 = tcMatchTy tvs1 res1 res2
892 mb_subst2 = tcMatchTyX tvs1 (expectJust "checkFieldCompat" mb_subst1) fty1 fty2
894 -------------------------------
895 checkValidDataCon :: TyCon -> DataCon -> TcM ()
896 checkValidDataCon tc con
897 = setSrcSpan (srcLocSpan (getSrcLoc con)) $
898 addErrCtxt (dataConCtxt con) $
899 do { traceTc "Validity of data con" (ppr con)
900 ; let tc_tvs = tyConTyVars tc
901 res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
902 actual_res_ty = dataConOrigResTy con
903 ; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs)
906 (badDataConTyCon con res_ty_tmpl actual_res_ty)
907 ; checkValidMonoType (dataConOrigResTy con)
908 -- Disallow MkT :: T (forall a. a->a)
909 -- Reason: it's really the argument of an equality constraint
910 ; checkValidType ctxt (dataConUserType con)
911 ; when (isNewTyCon tc) (checkNewDataCon con)
912 ; mapM_ check_bang (dataConStrictMarks con `zip` [1..])
915 ctxt = ConArgCtxt (dataConName con)
916 check_bang (HsUnpackFailed, n) = addWarnTc (cant_unbox_msg n)
917 check_bang _ = return ()
919 cant_unbox_msg n = sep [ ptext (sLit "Ignoring unusable UNPACK pragma on the")
920 , speakNth n <+> ptext (sLit "argument of") <+> quotes (ppr con)]
922 -------------------------------
923 checkNewDataCon :: DataCon -> TcM ()
924 -- Checks for the data constructor of a newtype
926 = do { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys))
928 ; checkTc (null eq_spec) (newtypePredError con)
929 -- Return type is (T a b c)
930 ; checkTc (null ex_tvs && null theta) (newtypeExError con)
932 ; checkTc (not (any isBanged (dataConStrictMarks con)))
933 (newtypeStrictError con)
937 (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con
939 -------------------------------
940 checkValidClass :: Class -> TcM ()
942 = do { constrained_class_methods <- xoptM Opt_ConstrainedClassMethods
943 ; multi_param_type_classes <- xoptM Opt_MultiParamTypeClasses
944 ; fundep_classes <- xoptM Opt_FunctionalDependencies
946 -- Check that the class is unary, unless GlaExs
947 ; checkTc (notNull tyvars) (nullaryClassErr cls)
948 ; checkTc (multi_param_type_classes || unary) (classArityErr cls)
949 ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls)
951 -- Check the super-classes
952 ; checkValidTheta (ClassSCCtxt (className cls)) theta
954 -- Check the class operations
955 ; mapM_ (check_op constrained_class_methods) op_stuff
957 -- Check that if the class has generic methods, then the
958 -- class has only one parameter. We can't do generic
959 -- multi-parameter type classes!
960 ; checkTc (unary || no_generics) (genericMultiParamErr cls)
963 (tyvars, fundeps, theta, _, _, op_stuff) = classExtraBigSig cls
964 unary = isSingleton tyvars
965 no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff]
967 check_op constrained_class_methods (sel_id, _)
968 = addErrCtxt (classOpCtxt sel_id tau) $ do
969 { checkValidTheta SigmaCtxt (tail theta)
970 -- The 'tail' removes the initial (C a) from the
971 -- class itself, leaving just the method type
973 ; traceTc "class op type" (ppr op_ty <+> ppr tau)
974 ; checkValidType (FunSigCtxt op_name) tau
976 -- Check that the type mentions at least one of
977 -- the class type variables...or at least one reachable
978 -- from one of the class variables. Example: tc223
979 -- class Error e => Game b mv e | b -> mv e where
980 -- newBoard :: MonadState b m => m ()
981 -- Here, MonadState has a fundep m->b, so newBoard is fine
982 ; let grown_tyvars = growThetaTyVars theta (mkVarSet tyvars)
983 ; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars)
984 (noClassTyVarErr cls sel_id)
987 op_name = idName sel_id
988 op_ty = idType sel_id
989 (_,theta1,tau1) = tcSplitSigmaTy op_ty
990 (_,theta2,tau2) = tcSplitSigmaTy tau1
991 (theta,tau) | constrained_class_methods = (theta1 ++ theta2, tau2)
992 | otherwise = (theta1, mkPhiTy (tail theta1) tau1)
993 -- Ugh! The function might have a type like
994 -- op :: forall a. C a => forall b. (Eq b, Eq a) => tau2
995 -- With -XConstrainedClassMethods, we want to allow this, even though the inner
996 -- forall has an (Eq a) constraint. Whereas in general, each constraint
997 -- in the context of a for-all must mention at least one quantified
998 -- type variable. What a mess!
1002 %************************************************************************
1004 Building record selectors
1006 %************************************************************************
1009 mkDefaultMethodIds :: [TyThing] -> [Id]
1010 -- See Note [Default method Ids and Template Haskell]
1011 mkDefaultMethodIds things
1012 = [ mkExportedLocalId dm_name (idType sel_id)
1013 | AClass cls <- things
1014 , (sel_id, DefMeth dm_name) <- classOpItems cls ]
1017 Note [Default method Ids and Template Haskell]
1018 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1019 Consider this (Trac #4169):
1020 class Numeric a where
1022 fromIntegerNum = ...
1025 ast = [d| instance Numeric Int |]
1027 When we typecheck 'ast' we have done the first pass over the class decl
1028 (in tcTyClDecls), but we have not yet typechecked the default-method
1029 declarations (becuase they can mention value declarations). So we
1030 must bring the default method Ids into scope first (so they can be seen
1031 when typechecking the [d| .. |] quote, and typecheck them later.
1034 mkRecSelBinds :: [TyThing] -> HsValBinds Name
1035 -- NB We produce *un-typechecked* bindings, rather like 'deriving'
1036 -- This makes life easier, because the later type checking will add
1037 -- all necessary type abstractions and applications
1038 mkRecSelBinds ty_things
1039 = ValBindsOut [(NonRecursive, b) | b <- binds] sigs
1041 (sigs, binds) = unzip rec_sels
1042 rec_sels = map mkRecSelBind [ (tc,fld)
1043 | ATyCon tc <- ty_things
1044 , fld <- tyConFields tc ]
1046 mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
1047 mkRecSelBind (tycon, sel_name)
1048 = (L loc (IdSig sel_id), unitBag (L loc sel_bind))
1050 loc = getSrcSpan tycon
1051 sel_id = Var.mkLocalVar rec_details sel_name sel_ty vanillaIdInfo
1052 rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty }
1054 -- Find a representative constructor, con1
1055 all_cons = tyConDataCons tycon
1056 cons_w_field = [ con | con <- all_cons
1057 , sel_name `elem` dataConFieldLabels con ]
1058 con1 = ASSERT( not (null cons_w_field) ) head cons_w_field
1060 -- Selector type; Note [Polymorphic selectors]
1061 field_ty = dataConFieldType con1 sel_name
1062 data_ty = dataConOrigResTy con1
1063 data_tvs = tyVarsOfType data_ty
1064 is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs)
1065 (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty
1066 sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors]
1067 | otherwise = mkForAllTys (varSetElems data_tvs ++ field_tvs) $
1068 mkPhiTy (dataConStupidTheta con1) $ -- Urgh!
1069 mkPhiTy field_theta $ -- Urgh!
1070 mkFunTy data_ty field_tau
1072 -- Make the binding: sel (C2 { fld = x }) = x
1073 -- sel (C7 { fld = x }) = x
1074 -- where cons_w_field = [C2,C7]
1075 sel_bind | is_naughty = mkFunBind sel_lname [mkSimpleMatch [] unit_rhs]
1076 | otherwise = mkFunBind sel_lname (map mk_match cons_w_field ++ deflt)
1077 mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)]
1078 (L loc (HsVar field_var))
1079 mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
1080 rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
1081 rec_field = HsRecField { hsRecFieldId = sel_lname
1082 , hsRecFieldArg = nlVarPat field_var
1083 , hsRecPun = False }
1084 sel_lname = L loc sel_name
1085 field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
1087 -- Add catch-all default case unless the case is exhaustive
1088 -- We do this explicitly so that we get a nice error message that
1089 -- mentions this particular record selector
1090 deflt | not (any is_unused all_cons) = []
1091 | otherwise = [mkSimpleMatch [nlWildPat]
1092 (nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID))
1095 -- Do not add a default case unless there are unmatched
1096 -- constructors. We must take account of GADTs, else we
1097 -- get overlap warning messages from the pattern-match checker
1098 is_unused con = not (con `elem` cons_w_field
1099 || dataConCannotMatch inst_tys con)
1100 inst_tys = tyConAppArgs data_ty
1102 unit_rhs = mkLHsTupleExpr []
1103 msg_lit = HsStringPrim $ mkFastString $
1104 occNameString (getOccName sel_name)
1107 tyConFields :: TyCon -> [FieldLabel]
1109 | isAlgTyCon tc = nub (concatMap dataConFieldLabels (tyConDataCons tc))
1113 Note [Polymorphic selectors]
1114 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1115 When a record has a polymorphic field, we pull the foralls out to the front.
1116 data T = MkT { f :: forall a. [a] -> a }
1117 Then f :: forall a. T -> [a] -> a
1118 NOT f :: T -> forall a. [a] -> a
1120 This is horrid. It's only needed in deeply obscure cases, which I hate.
1121 The only case I know is test tc163, which is worth looking at. It's far
1122 from clear that this test should succeed at all!
1124 Note [Naughty record selectors]
1125 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1126 A "naughty" field is one for which we can't define a record
1127 selector, because an existential type variable would escape. For example:
1128 data T = forall a. MkT { x,y::a }
1129 We obviously can't define
1131 Nevertheless we *do* put a RecSelId into the type environment
1132 so that if the user tries to use 'x' as a selector we can bleat
1133 helpfully, rather than saying unhelpfully that 'x' is not in scope.
1134 Hence the sel_naughty flag, to identify record selectors that don't really exist.
1136 In general, a field is "naughty" if its type mentions a type variable that
1137 isn't in the result type of the constructor. Note that this *allows*
1138 GADT record selectors (Note [GADT record selectors]) whose types may look
1139 like sel :: T [a] -> a
1141 For naughty selectors we make a dummy binding
1143 for naughty selectors, so that the later type-check will add them to the
1144 environment, and they'll be exported. The function is never called, because
1145 the tyepchecker spots the sel_naughty field.
1147 Note [GADT record selectors]
1148 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1149 For GADTs, we require that all constructors with a common field 'f' have the same
1150 result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon]
1153 T1 { f :: Maybe a } :: T [a]
1154 T2 { f :: Maybe a, y :: b } :: T [a]
1156 and now the selector takes that result type as its argument:
1157 f :: forall a. T [a] -> Maybe a
1159 Details: the "real" types of T1,T2 are:
1160 T1 :: forall r a. (r~[a]) => a -> T r
1161 T2 :: forall r a b. (r~[a]) => a -> b -> T r
1163 So the selector loooks like this:
1164 f :: forall a. T [a] -> Maybe a
1167 T1 c (g:[a]~[c]) (v:Maybe c) -> v `cast` Maybe (right (sym g))
1168 T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g))
1170 Note the forall'd tyvars of the selector are just the free tyvars
1171 of the result type; there may be other tyvars in the constructor's
1172 type (e.g. 'b' in T2).
1174 Note the need for casts in the result!
1176 Note [Selector running example]
1177 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1178 It's OK to combine GADTs and type families. Here's a running example:
1180 data instance T [a] where
1181 T1 { fld :: b } :: T [Maybe b]
1183 The representation type looks like this
1185 T1 { fld :: b } :: :R7T (Maybe b)
1187 and there's coercion from the family type to the representation type
1188 :CoR7T a :: T [a] ~ :R7T a
1190 The selector we want for fld looks like this:
1192 fld :: forall b. T [Maybe b] -> b
1193 fld = /\b. \(d::T [Maybe b]).
1194 case d `cast` :CoR7T (Maybe b) of
1197 The scrutinee of the case has type :R7T (Maybe b), which can be
1198 gotten by appying the eq_spec to the univ_tvs of the data con.
1200 %************************************************************************
1204 %************************************************************************
1207 resultTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc
1208 resultTypeMisMatch field_name con1 con2
1209 = vcat [sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2,
1210 ptext (sLit "have a common field") <+> quotes (ppr field_name) <> comma],
1211 nest 2 $ ptext (sLit "but have different result types")]
1213 fieldTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc
1214 fieldTypeMisMatch field_name con1 con2
1215 = sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2,
1216 ptext (sLit "give different types for field"), quotes (ppr field_name)]
1218 dataConCtxt :: Outputable a => a -> SDoc
1219 dataConCtxt con = ptext (sLit "In the definition of data constructor") <+> quotes (ppr con)
1221 classOpCtxt :: Var -> Type -> SDoc
1222 classOpCtxt sel_id tau = sep [ptext (sLit "When checking the class method:"),
1223 nest 2 (ppr sel_id <+> dcolon <+> ppr tau)]
1225 nullaryClassErr :: Class -> SDoc
1227 = ptext (sLit "No parameters for class") <+> quotes (ppr cls)
1229 classArityErr :: Class -> SDoc
1231 = vcat [ptext (sLit "Too many parameters for class") <+> quotes (ppr cls),
1232 parens (ptext (sLit "Use -XMultiParamTypeClasses to allow multi-parameter classes"))]
1234 classFunDepsErr :: Class -> SDoc
1236 = vcat [ptext (sLit "Fundeps in class") <+> quotes (ppr cls),
1237 parens (ptext (sLit "Use -XFunctionalDependencies to allow fundeps"))]
1239 noClassTyVarErr :: Class -> Var -> SDoc
1240 noClassTyVarErr clas op
1241 = sep [ptext (sLit "The class method") <+> quotes (ppr op),
1242 ptext (sLit "mentions none of the type variables of the class") <+>
1243 ppr clas <+> hsep (map ppr (classTyVars clas))]
1245 genericMultiParamErr :: Class -> SDoc
1246 genericMultiParamErr clas
1247 = ptext (sLit "The multi-parameter class") <+> quotes (ppr clas) <+>
1248 ptext (sLit "cannot have generic methods")
1250 recSynErr :: [LTyClDecl Name] -> TcRn ()
1252 = setSrcSpan (getLoc (head sorted_decls)) $
1253 addErr (sep [ptext (sLit "Cycle in type synonym declarations:"),
1254 nest 2 (vcat (map ppr_decl sorted_decls))])
1256 sorted_decls = sortLocated syn_decls
1257 ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl
1259 recClsErr :: [Located (TyClDecl Name)] -> TcRn ()
1261 = setSrcSpan (getLoc (head sorted_decls)) $
1262 addErr (sep [ptext (sLit "Cycle in class declarations (via superclasses):"),
1263 nest 2 (vcat (map ppr_decl sorted_decls))])
1265 sorted_decls = sortLocated cls_decls
1266 ppr_decl (L loc decl) = ppr loc <> colon <+> ppr (decl { tcdSigs = [] })
1268 sortLocated :: [Located a] -> [Located a]
1269 sortLocated things = sortLe le things
1271 le (L l1 _) (L l2 _) = l1 <= l2
1273 badDataConTyCon :: DataCon -> Type -> Type -> SDoc
1274 badDataConTyCon data_con res_ty_tmpl actual_res_ty
1275 = hang (ptext (sLit "Data constructor") <+> quotes (ppr data_con) <+>
1276 ptext (sLit "returns type") <+> quotes (ppr actual_res_ty))
1277 2 (ptext (sLit "instead of an instance of its parent type") <+> quotes (ppr res_ty_tmpl))
1279 badGadtDecl :: Name -> SDoc
1281 = vcat [ ptext (sLit "Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name)
1282 , nest 2 (parens $ ptext (sLit "Use -XGADTs to allow GADTs")) ]
1284 badExistential :: Located Name -> SDoc
1285 badExistential con_name
1286 = hang (ptext (sLit "Data constructor") <+> quotes (ppr con_name) <+>
1287 ptext (sLit "has existential type variables, a context, or a specialised result type"))
1288 2 (parens $ ptext (sLit "Use -XExistentialQuantification or -XGADTs to allow this"))
1290 badStupidTheta :: Name -> SDoc
1291 badStupidTheta tc_name
1292 = ptext (sLit "A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name)
1294 newtypeConError :: Name -> Int -> SDoc
1295 newtypeConError tycon n
1296 = sep [ptext (sLit "A newtype must have exactly one constructor,"),
1297 nest 2 $ ptext (sLit "but") <+> quotes (ppr tycon) <+> ptext (sLit "has") <+> speakN n ]
1299 newtypeExError :: DataCon -> SDoc
1301 = sep [ptext (sLit "A newtype constructor cannot have an existential context,"),
1302 nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does")]
1304 newtypeStrictError :: DataCon -> SDoc
1305 newtypeStrictError con
1306 = sep [ptext (sLit "A newtype constructor cannot have a strictness annotation,"),
1307 nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does")]
1309 newtypePredError :: DataCon -> SDoc
1310 newtypePredError con
1311 = sep [ptext (sLit "A newtype constructor must have a return type of form T a1 ... an"),
1312 nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does not")]
1314 newtypeFieldErr :: DataCon -> Int -> SDoc
1315 newtypeFieldErr con_name n_flds
1316 = sep [ptext (sLit "The constructor of a newtype must have exactly one field"),
1317 nest 2 $ ptext (sLit "but") <+> quotes (ppr con_name) <+> ptext (sLit "has") <+> speakN n_flds]
1319 badSigTyDecl :: Name -> SDoc
1320 badSigTyDecl tc_name
1321 = vcat [ ptext (sLit "Illegal kind signature") <+>
1322 quotes (ppr tc_name)
1323 , nest 2 (parens $ ptext (sLit "Use -XKindSignatures to allow kind signatures")) ]
1325 badFamInstDecl :: Outputable a => a -> SDoc
1326 badFamInstDecl tc_name
1327 = vcat [ ptext (sLit "Illegal family instance for") <+>
1328 quotes (ppr tc_name)
1329 , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ]
1331 emptyConDeclsErr :: Name -> SDoc
1332 emptyConDeclsErr tycon
1333 = sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"),
1334 nest 2 $ ptext (sLit "(-XEmptyDataDecls permits this)")]