Commit 6ea06bbf authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Do dependency analysis when kind-checking type declarations

This patch fixes Trac #4875.  The main point is to do dependency
analysis on type and class declarations, and kind-check them in
dependency order, so as to improve error messages.

This patch means that a few programs that would typecheck before won't
typecheck any more; but before we were (naughtily) going beyond
Haskell 98 without any language-extension flags, and Trac #4875
convinces me that doing so is a Bad Idea.

Here's an example that won't typecheck any more
       data T a b = MkT (a b)
       type F k = T k Maybe

If you look at T on its own you'd default 'a' to kind *->*;
and then kind-checking would fail on F.

But GHC currently accepts this program beause it looks at
the *occurrences* of T.
parent 338cac01
......@@ -119,7 +119,7 @@ repTopDs group
decls <- addBinds ss (do {
val_ds <- rep_val_binds (hs_valds group) ;
tycl_ds <- mapM repTyClD (hs_tyclds group) ;
tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ;
inst_ds <- mapM repInstD' (hs_instds group) ;
for_ds <- mapM repForD (hs_fords group) ;
-- more needed
......
......@@ -126,7 +126,12 @@ data HsDecl id
data HsGroup id
= HsGroup {
hs_valds :: HsValBinds id,
hs_tyclds :: [LTyClDecl id],
hs_tyclds :: [[LTyClDecl id]],
-- A list of mutually-recursive groups
-- Parser generates a singleton list;
-- renamer does dependency analysis
hs_instds :: [LInstDecl id],
hs_derivds :: [LDerivDecl id],
......@@ -228,7 +233,8 @@ instance OutputableBndr name => Outputable (HsGroup name) where
if isEmptyValBinds val_decls
then Nothing
else Just (ppr val_decls),
ppr_ds tycl_decls, ppr_ds inst_decls,
ppr_ds (concat tycl_decls),
ppr_ds inst_decls,
ppr_ds deriv_decls,
ppr_ds foreign_decls]
where
......
......@@ -60,7 +60,7 @@ module HsUtils(
collectLStmtBinders, collectStmtBinders,
collectSigTysFromPats, collectSigTysFromPat,
hsTyClDeclBinders, hsTyClDeclsBinders, hsConDeclsBinders,
hsTyClDeclBinders, hsTyClDeclsBinders,
hsForeignDeclsBinders, hsGroupBinders
) where
......@@ -572,9 +572,10 @@ hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name]
hsForeignDeclsBinders foreign_decls
= [n | L _ (ForeignImport (L _ n) _ _) <- foreign_decls]
hsTyClDeclsBinders :: [Located (TyClDecl Name)] -> [Located (InstDecl Name)] -> [Name]
hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name]
hsTyClDeclsBinders tycl_decls inst_decls
= [n | d <- instDeclATs inst_decls ++ tycl_decls, L _ n <- hsTyClDeclBinders d]
= [n | d <- instDeclATs inst_decls ++ concat tycl_decls
, L _ n <- hsTyClDeclBinders d]
hsTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
-- ^ Returns all the /binding/ names of the decl, along with their SrcLocs.
......
......@@ -446,7 +446,7 @@ get_local_binders gbl_env (HsGroup {hs_valds = ValBindsIn _ val_sigs,
hs_fords = foreign_decls })
= do { -- separate out the family instance declarations
let (tyinst_decls1, tycl_decls_noinsts)
= partition (isFamInstDecl . unLoc) tycl_decls
= partition (isFamInstDecl . unLoc) (concat tycl_decls)
tyinst_decls = tyinst_decls1 ++ instDeclATs inst_decls
-- process all type/class decls except family instances
......
......@@ -50,9 +50,10 @@ import DynFlags
import HscTypes ( HscEnv, hsc_dflags )
import BasicTypes ( Boxity(..) )
import ListSetOps ( findDupsEq )
import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
import Control.Monad
import Maybes( orElse )
import Data.Maybe
\end{code}
......@@ -146,7 +147,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
-- means we'll only report a declaration as unused if it isn't
-- mentioned at all. Ah well.
traceRn (text "Start rnTyClDecls") ;
(rn_tycl_decls, src_fvs1) <- rnList rnTyClDecl tycl_decls ;
(rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
-- (F) Rename Value declarations right-hand sides
traceRn (text "Start rnmono") ;
......@@ -218,11 +219,6 @@ inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a
inNewEnv env cont = do e <- env
setGblEnv e $ cont e
rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
-- Used for external core
rnTyClDecls tycl_decls = do (decls', _fvs) <- rnList rnTyClDecl tycl_decls
return decls'
addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
-- This function could be defined lower down in the module hierarchy,
-- but there doesn't seem anywhere very logical to put it.
......@@ -681,6 +677,18 @@ and then go over it again to rename the tyvars!
However, we can also do some scoping checks at the same time.
\begin{code}
rnTyClDecls :: [[LTyClDecl RdrName]] -> RnM ([[LTyClDecl Name]], FreeVars)
-- Renamed the declarations and do depedency analysis on them
rnTyClDecls tycl_ds
= do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (concat tycl_ds)
; let sccs :: [SCC (LTyClDecl Name)]
sccs = depAnalTyClDecls ds_w_fvs
all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs
; return (map flattenSCC sccs, all_fvs) }
rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars)
rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name})
= lookupLocatedTopBndrRn name `thenM` \ name' ->
......@@ -832,6 +840,35 @@ to cause programs to break unnecessarily (notably HList). So if there
are no data constructors we allow h98_style = True
\begin{code}
depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)]
-- See Note [Dependency analysis of type and class decls]
depAnalTyClDecls ds_w_fvs
= stronglyConnCompFromEdgedVertices edges
where
edges = [ (d, tcdName (unLoc d), map get_assoc (nameSetToList fvs))
| (d, fvs) <- ds_w_fvs ]
get_assoc n = lookupNameEnv assoc_env n `orElse` n
assoc_env = mkNameEnv [ (tcdName assoc_decl, cls_name)
| (L _ (ClassDecl { tcdLName = L _ cls_name
, tcdATs = ats }) ,_) <- ds_w_fvs
, L _ assoc_decl <- ats ]
\end{code}
Note [Dependency analysis of type and class decls]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We need to do dependency analysis on type and class declarations
else we get bad error messages. Consider
data T f a = MkT f a
data S f a = MkS f (T f a)
This has a kind error, but the error message is better if you
check T first, (fixing its kind) and *then* S. If you do kind
inference together, you might get an error reported in S, which
is jolly confusing. See Trac #4875
%*********************************************************
%* *
\subsection{Support code for type/data declarations}
......@@ -1041,7 +1078,7 @@ badDataCon name
Get the mapping from constructors to fields for this module.
It's convenient to do this after the data type decls have been renamed
\begin{code}
extendRecordFieldEnv :: [LTyClDecl RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv
extendRecordFieldEnv :: [[LTyClDecl RdrName]] -> [LInstDecl RdrName] -> TcM TcGblEnv
extendRecordFieldEnv tycl_decls inst_decls
= do { tcg_env <- getGblEnv
; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
......@@ -1059,7 +1096,7 @@ extendRecordFieldEnv tycl_decls inst_decls
all_data_cons :: [ConDecl RdrName]
all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls
, L _ con <- cons ]
all_tycl_decls = at_tycl_decls ++ tycl_decls
all_tycl_decls = at_tycl_decls ++ concat tycl_decls
at_tycl_decls = instDeclATs inst_decls -- Do not forget associated types!
get_con (ConDecl { con_name = con, con_details = RecCon flds })
......@@ -1148,9 +1185,9 @@ add gp _ (QuasiQuoteD qq) ds -- Expand quasiquotes
add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
| isClassDecl d
= let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
| otherwise
= addl (gp { hs_tyclds = L l d : ts }) ds
= addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
-- Signatures: fixity sigs go a different place than all others
add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
......@@ -1180,6 +1217,10 @@ add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
add gp l (DocD d) ds
= addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
add_tycld :: LTyClDecl a -> [[LTyClDecl a]] -> [[LTyClDecl a]]
add_tycld d [] = [[d]]
add_tycld d (ds:dss) = (d:ds) : dss
add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
......
......@@ -371,7 +371,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
; let { (local_info,
at_tycons_s) = unzip local_info_tycons
; at_idx_tycons = concat at_tycons_s ++ idx_tycons
; clas_decls = filter (isClassDecl.unLoc) tycl_decls
; clas_decls = filter (isClassDecl . unLoc) tycl_decls
; implicit_things = concatMap implicitTyThings at_idx_tycons
; aux_binds = mkRecSelBinds at_idx_tycons
}
......
......@@ -290,7 +290,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
setEnvs tc_envs $ do {
rn_decls <- checkNoErrs $ rnTyClDecls ldecls ;
(rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [ldecls] ;
-- Dump trace of renaming part
rnDump (ppr rn_decls) ;
......@@ -348,7 +348,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
mkFakeGroup :: [LTyClDecl a] -> HsGroup a
mkFakeGroup decls -- Rather clumsy; lots of unused fields
= emptyRdrGroup { hs_tyclds = decls }
= emptyRdrGroup { hs_tyclds = [decls] }
\end{code}
......@@ -504,7 +504,7 @@ tcRnHsBootDecls decls
-- Family instance declarations are rejected here
; traceTc "Tc3" empty
; (tcg_env, inst_infos, _deriv_binds)
<- tcInstDecls1 tycl_decls inst_decls deriv_decls
<- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls
; setGblEnv tcg_env $ do {
-- Typecheck value declarations
......@@ -846,7 +846,7 @@ tcTopSrcDecls boot_details
-- and import the supporting declarations
traceTc "Tc3" empty ;
(tcg_env, inst_infos, deriv_binds)
<- tcInstDecls1 tycl_decls inst_decls deriv_decls;
<- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls;
setGblEnv tcg_env $ do {
-- Foreign import declarations next.
......@@ -875,7 +875,7 @@ tcTopSrcDecls boot_details
-- Second pass over class and instance declarations,
traceTc "Tc6" empty ;
inst_binds <- tcInstDecls2 tycl_decls inst_infos ;
inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
-- Foreign exports
traceTc "Tc7" empty ;
......
......@@ -60,180 +60,78 @@ import Data.List
%* *
%************************************************************************
Dealing with a group
~~~~~~~~~~~~~~~~~~~~
Consider a mutually-recursive group, binding
a type constructor T and a class C.
Step 1: getInitialKind
Construct a KindEnv by binding T and C to a kind variable
Step 2: kcTyClDecl
In that environment, do a kind check
Step 3: Zonk the kinds
Step 4: buildTyConOrClass
Construct an environment binding T to a TyCon and C to a Class.
a) Their kinds comes from zonking the relevant kind variable
b) Their arity (for synonyms) comes direct from the decl
c) The funcional dependencies come from the decl
d) The rest comes a knot-tied binding of T and C, returned from Step 4
e) The variances of the tycons in the group is calculated from
the knot-tied stuff
Step 5: tcTyClDecl1
In this environment, walk over the decls, constructing the TyCons and Classes.
This uses in a strict way items (a)-(c) above, which is why they must
be constructed in Step 4. Feed the results back to Step 4.
For this step, pass the is-recursive flag as the wimp-out flag
to tcTyClDecl1.
Step 6: Extend environment
We extend the type environment with bindings not only for the TyCons and Classes,
but also for their "implicit Ids" like data constructors and class selectors
Step 7: checkValidTyCl
For a recursive group only, check all the decls again, just
to check all the side conditions on validity. We could not
do this before because we were in a mutually recursive knot.
Identification of recursive TyCons
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
@TyThing@s.
Identifying a TyCon as recursive serves two purposes
1. Avoid infinite types. Non-recursive newtypes are treated as
"transparent", like type synonyms, after the type checker. If we did
this for all newtypes, we'd get infinite types. So we figure out for
each newtype whether it is "recursive", and add a coercion if so. In
effect, we are trying to "cut the loops" by identifying a loop-breaker.
2. Avoid infinite unboxing. This is nothing to do with newtypes.
Suppose we have
data T = MkT Int T
f (MkT x t) = f t
Well, this function diverges, but we don't want the strictness analyser
to diverge. But the strictness analyser will diverge because it looks
deeper and deeper into the structure of T. (I believe there are
examples where the function does something sane, and the strictness
analyser still diverges, but I can't see one now.)
Now, concerning (1), the FC2 branch currently adds a coercion for ALL
newtypes. I did this as an experiment, to try to expose cases in which
the coercions got in the way of optimisations. If it turns out that we
can indeed always use a coercion, then we don't risk recursive types,
and don't need to figure out what the loop breakers are.
For newtype *families* though, we will always have a coercion, so they
are always loop breakers! So you can easily adjust the current
algorithm by simply treating all newtype families as loop breakers (and
indeed type families). I think.
\begin{code}
tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name]
tcTyAndClassDecls :: ModDetails
-> [[LTyClDecl Name]] -- Mutually-recursive groups in dependency order
-> TcM (TcGblEnv, -- Input env extended by types and classes
-- and their implicit Ids,DataCons
HsValBinds Name, -- Renamed bindings for record selectors
[Id]) -- Default method ids
-- Fails if there are any errors
tcTyAndClassDecls boot_details allDecls
tcTyAndClassDecls boot_details decls_s
= checkNoErrs $ -- The code recovers internally, but if anything gave rise to
-- an error we'd better stop now, to avoid a cascade
do { -- Omit instances of type families; they are handled together
-- with the *heads* of class instances
; let decls = filter (not . isFamInstDecl . unLoc) allDecls
-- First check for cyclic type synonysm or classes
-- See notes with checkCycleErrs
; checkCycleErrs decls
; mod <- getModule
; traceTc "tcTyAndCl" (ppr mod)
; (syn_tycons, alg_tyclss) <- fixM (\ ~(_rec_syn_tycons, rec_alg_tyclss) ->
do { let { -- Seperate ordinary synonyms from all other type and
-- class declarations and add all associated type
-- declarations from type classes. The latter is
-- required so that the temporary environment for the
-- knot includes all associated family declarations.
; (syn_decls, alg_decls) = partition (isSynDecl . unLoc)
decls
; alg_at_decls = concatMap addATs alg_decls
}
-- Extend the global env with the knot-tied results
-- for data types and classes
--
-- We must populate the environment with the loop-tied
-- T's right away, because the kind checker may "fault
-- in" some type constructors that recursively
-- mention T
; let gbl_things = mkGlobalThings alg_at_decls rec_alg_tyclss
; tcExtendRecEnv gbl_things $ do
-- Kind-check the declarations
{ (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls
; let { -- Calculate rec-flag
; calc_rec = calcRecFlags boot_details rec_alg_tyclss
; tc_decl = addLocM (tcTyClDecl calc_rec) }
-- Type-check the type synonyms, and extend the envt
; syn_tycons <- tcSynDecls kc_syn_decls
; tcExtendGlobalEnv syn_tycons $ do
-- Type-check the data types and classes
{ alg_tyclss <- mapM tc_decl kc_alg_decls
; return (syn_tycons, concat alg_tyclss)
}}})
-- Finished with knot-tying now
-- Extend the environment with the finished things
; tcExtendGlobalEnv (syn_tycons ++ alg_tyclss) $ do
-- Perform the validity check
{ traceTc "ready for validity check" empty
; mapM_ (addLocM checkValidTyCl) decls
do { let tyclds_s = map (filterOut (isFamInstDecl . unLoc)) decls_s
-- Remove family instance decls altogether
-- They are dealt with by TcInstDcls
; tyclss <- fixM $ \ rec_tyclss ->
tcExtendRecEnv (zipRecTyClss tyclds_s rec_tyclss) $
-- We must populate the environment with the loop-tied
-- T's right away (even before kind checking), because
-- the kind checker may "fault in" some type constructors
-- that recursively mention T
do { -- Kind-check in dependency order
-- See Note [Kind checking for type and class decls]
kc_decls <- kcTyClDecls tyclds_s
-- And now build the TyCons/Classes
; let rec_flags = calcRecFlags boot_details rec_tyclss
; concatMapM (tcTyClDecl rec_flags) kc_decls }
; tcExtendGlobalEnv tyclss $ do
{ -- Perform the validity check
-- We can do this now because we are done with the recursive knot
traceTc "ready for validity check" empty
; mapM_ (addLocM checkValidTyCl) (concat tyclds_s)
; traceTc "done" empty
-- Add the implicit things;
-- we want them in the environment because
-- we want them in the environment because
-- they may be mentioned in interface files
-- NB: All associated types and their implicit things will be added a
-- second time here. This doesn't matter as the definitions are
-- the same.
; let { implicit_things = concatMap implicitTyThings alg_tyclss
; rec_sel_binds = mkRecSelBinds alg_tyclss
; dm_ids = mkDefaultMethodIds alg_tyclss }
; traceTc "Adding types and classes" $ vcat
[ ppr alg_tyclss
, text "and" <+> ppr implicit_things ]
; let { implicit_things = concatMap implicitTyThings tyclss
; rec_sel_binds = mkRecSelBinds tyclss
; dm_ids = mkDefaultMethodIds tyclss }
; env <- tcExtendGlobalEnv implicit_things getGblEnv
; return (env, rec_sel_binds, dm_ids) }
}
where
-- Pull associated types out of class declarations, to tie them into the
-- knot above.
-- NB: We put them in the same place in the list as `tcTyClDecl' will
-- eventually put the matching `TyThing's. That's crucial; otherwise,
-- the two argument lists of `mkGlobalThings' don't match up.
addATs decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats
addATs decl = [decl]
mkGlobalThings :: [LTyClDecl Name] -- The decls
-> [TyThing] -- Knot-tied, in 1-1 correspondence with the decls
-> [(Name,TyThing)]
-- Driven by the Decls, and treating the TyThings lazily
-- make a TypeEnv for the new things
mkGlobalThings decls things
= map mk_thing (decls `zipLazy` things)
; return (env, rec_sel_binds, dm_ids) } }
zipRecTyClss :: [[LTyClDecl Name]]
-> [TyThing] -- Knot-tied
-> [(Name,TyThing)]
-- Build a name-TyThing mapping for the things bound by decls
-- being careful not to look at the [TyThing]
-- The TyThings in the result list must have a visible ATyCon/AClass,
-- because typechecking types (in, say, tcTyClDecl) looks at this outer constructor
zipRecTyClss decls_s rec_things
= [ get decl | decls <- decls_s, L _ decl <- flattenATs decls ]
where
mk_thing (L _ (ClassDecl {tcdLName = L _ name}), ~(AClass cl))
= (name, AClass cl)
mk_thing (L _ decl, ~(ATyCon tc))
= (tcdName decl, ATyCon tc)
rec_type_env :: TypeEnv
rec_type_env = mkTypeEnv rec_things
get :: TyClDecl Name -> (Name, TyThing)
get (ClassDecl {tcdLName = L _ name}) = (name, AClass cl)
where
Just (AClass cl) = lookupTypeEnv rec_type_env name
get decl = (name, ATyCon tc)
where
name = tcdName decl
Just (ATyCon tc) = lookupTypeEnv rec_type_env name
\end{code}
......@@ -425,6 +323,25 @@ kcIdxTyPats decl thing_inside
%* *
%************************************************************************
Note [Kind checking for type and class decls]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Kind checking is done thus:
1. Make up a kind variable for each parameter of the *data* type,
and class, decls, and extend the kind environment (which is in
the TcLclEnv)
2. Dependency-analyse the type *synonyms* (which must be non-recursive),
and kind-check them in dependency order. Extend the kind envt.
3. Kind check the data type and class decls
Synonyms are treated differently to data type and classes,
because a type synonym can be an unboxed type
type Foo = Int#
and a kind variable can't unify with UnboxedTypeKind
So we infer their kinds in dependency order
We need to kind check all types in the mutually recursive group
before we know the kind of the type variables. For example:
......@@ -459,48 +376,52 @@ instances of families altogether in the following. However, we need to
include the kinds of associated families into the construction of the
initial kind environment. (This is handled by `allDecls').
\begin{code}
kcTyClDecls :: [LTyClDecl Name] -> [Located (TyClDecl Name)]
-> TcM ([LTyClDecl Name], [Located (TyClDecl Name)])
kcTyClDecls syn_decls alg_decls
= do { -- First extend the kind env with each data type, class, and
-- indexed type, mapping them to a type variable
let initialKindDecls = concat [allDecls decl | L _ decl <- alg_decls]
; alg_kinds <- mapM getInitialKind initialKindDecls
; tcExtendKindEnv alg_kinds $ do
-- Now kind-check the type synonyms, in dependency order
-- We do these differently to data type and classes,
-- because a type synonym can be an unboxed type
-- type Foo = Int#
-- and a kind variable can't unify with UnboxedTypeKind
-- So we infer their kinds in dependency order
{ (kc_syn_decls, syn_kinds) <- kcSynDecls (calcSynCycles syn_decls)
; tcExtendKindEnv syn_kinds $ do
-- Now kind-check the data type, class, and kind signatures,
-- returning kind-annotated decls; we don't kind-check
-- instances of indexed types yet, but leave this to
-- `tcInstDecls1'
{ kc_alg_decls <- mapM (wrapLocM kcTyClDecl)
(filter (not . isFamInstDecl . unLoc) alg_decls)
; return (kc_syn_decls, kc_alg_decls) }}}
kcTyClDecls :: [[LTyClDecl Name]] -> TcM [LTyClDecl Name]
kcTyClDecls [] = return []
kcTyClDecls (decls : decls_s) = do { (tcl_env, kc_decls1) <- kcTyClDecls1 decls
; kc_decls2 <- setLclEnv tcl_env (kcTyClDecls decls_s)
; return (kc_decls1 ++ kc_decls2) }
kcTyClDecls1 :: [LTyClDecl Name] -> TcM (TcLclEnv, [LTyClDecl Name])
kcTyClDecls1 decls
= do { -- Omit instances of type families; they are handled together
-- with the *heads* of class instances
; let (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls
alg_at_decls = flattenATs alg_decls
; mod <- getModule
; traceTc "tcTyAndCl" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls))
-- First check for cyclic classes
; checkClassCycleErrs alg_decls
-- Kind checking; see Note [Kind checking for type and class decls]
; alg_kinds <- mapM getInitialKind alg_at_decls
; tcExtendKindEnv alg_kinds $ do
{ (kc_syn_decls, tcl_env) <- kcSynDecls (calcSynCycles syn_decls)
; setLclEnv tcl_env $ do
{ kc_alg_decls <- mapM (wrapLocM kcTyClDecl) alg_decls
-- Kind checking done for this group, so zonk the kind variables
-- See Note [Kind checking for type and class decls]
; mapM_ (zonkTcKindToKind . snd) alg_kinds
; return (tcl_env, kc_syn_decls ++ kc_alg_decls) } } }
flattenATs :: [LTyClDecl Name] -> [LTyClDecl Name]
flattenATs decls = concatMap flatten decls
where
-- get all declarations relevant for determining the initial kind
-- environment
allDecls (decl@ClassDecl {tcdATs = ats}) = decl : [ at
| L _ at <- ats
, isFamilyDecl at]
allDecls decl | isFamInstDecl decl = []
| otherwise = [decl]
flatten decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats
flatten decl = [decl]
------------------------------------------------------------------------
getInitialKind :: TyClDecl Name -> TcM (Name, TcKind)
getInitialKind :: LTyClDecl Name -> TcM (Name, TcKind)
-- Only for data type, class, and indexed type declarations
-- Get as much info as possible from the data, class, or indexed type decl,
-- so as to maximise usefulness of error messages
getInitialKind decl
getInitialKind (L _ decl)
= do { arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl)
; res_kind <- mk_res_kind decl
; return (tcdName decl, mkArrowKinds arg_kinds res_kind) }
......@@ -518,13 +439,13 @@ getInitialKind decl
----------------
kcSynDecls :: [SCC (LTyClDecl Name)]
-> TcM ([LTyClDecl Name], -- Kind-annotated decls
[(Name,TcKind)]) -- Kind bindings
TcLclEnv) -- Kind bindings
kcSynDecls []
= return ([], [])
= do { tcl_env <- getLclEnv; return ([], tcl_env) }
kcSynDecls (group : groups)
= do { (decl, nk) <- kcSynDecl group
; (decls, nks) <- tcExtendKindEnv [nk] (kcSynDecls groups)
; return (decl:decls, nk:nks) }
= do { (decl, nk) <- kcSynDecl group
; (decls, tcl_env) <- tcExtendKindEnv [nk] (kcSynDecls groups)
; return (decl:decls, tcl_env) }
----------------
kcSynDecl :: SCC (LTyClDecl Name)
......@@ -675,31 +596,11 @@ kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d)
%************************************************************************
\begin{code}
tcSynDecls :: [LTyClDecl Name] -> TcM [TyThing]
tcSynDecls [] = return []
tcSynDecls (decl : decls)
= do { syn_tc <- addLocM tcSynDecl decl
; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls decls)
; return (syn_tc : syn_tcs) }
tcTyClDecl :: (Name -> RecFlag) -> LTyClDecl Name -> TcM [TyThing]
-- "type"
tcSynDecl :: TyClDecl Name -> TcM TyThing
tcSynDecl
(TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
= tcTyVarBndrs tvs $ \ tvs' -> do
{ traceTc "tcd1" (ppr tc_name)
; rhs_ty' <- tcHsKindedType rhs_ty
; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty')
(typeKind rhs_ty') NoParentTyCon Nothing
; return (ATyCon tycon)
}
tcSynDecl d = pprPanic "tcSynDecl" (ppr d)
--------------------
tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
tcTyClDecl calc_isrec decl
= tcAddDeclCtxt decl (tcTyClDecl1 NoParentTyCon calc_isrec decl)
tcTyClDecl calc_isrec (L loc decl)
= setSrcSpan loc $ tcAddDeclCtxt decl $
tcTyClDecl1 NoParentTyCon calc_isrec decl
-- "type family" declarations
tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
......@@ -738,12 +639,24 @@ tcTyClDecl1 parent _calc_isrec
; return [ATyCon tycon]
}
-- "type"
tcTyClDecl1 _parent _calc_isrec
(TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
= ASSERT( isNoParent _parent )
tcTyVarBndrs tvs $ \ tvs' -> do
{ traceTc "tcd1" (ppr tc_name)
; rhs_ty' <- tcHsKindedType rhs_ty
; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty')
(typeKind rhs_ty') NoParentTyCon Nothing
; return [ATyCon tycon] }
-- "newtype" and "data"
-- NB: not used for newtype/data instances (whether associated or not)
tcTyClDecl1 parent calc_isrec
tcTyClDecl1 _parent calc_isrec
(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
<