import TcMonad
import TcEnv ( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
- tcExtendKindEnv, tcLookup, tcExtendGlobalEnv, tcExtendGlobalValEnv,
+ tcExtendKindEnv, tcLookup, tcExtendGlobalEnv,
isLocalThing )
-import TcTyDecls ( tcTyDecl, kcConDetails, checkValidTyCon )
-import TcClassDcl ( tcClassDecl1, checkValidClass )
+import TcTyDecls ( tcTyDecl, kcConDetails )
+import TcClassDcl ( tcClassDecl1 )
import TcInstDcls ( tcAddDeclCtxt )
import TcMonoType ( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars )
-import TcMType ( unifyKind, newKindVar, zonkKindEnv )
+import TcMType ( newKindVar, zonkKindEnv, checkValidTyCon, checkValidClass )
+import TcUnify ( unifyKind )
import TcType ( Type, Kind, TcKind, mkArrowKind, liftedTypeKind, zipFunTys )
import Type ( splitTyConApp_maybe )
import Variance ( calcTyConArgVrcs )
import Class ( Class, mkClass, classTyCon )
-import TyCon ( TyCon, ArgVrcs, AlgTyConFlavour(..),
+import TyCon ( TyCon, ArgVrcs, AlgTyConFlavour(..), DataConDetails(..), visibleDataCons,
tyConKind, tyConTyVars, tyConDataCons, isNewTyCon,
mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon,
)
tcTyAndClassDecls :: RecTcEnv -- Knot tying stuff
-> Module -- Current module
-> [RenamedTyClDecl]
- -> TcM TcEnv
+ -> TcM [TyThing] -- Returns newly defined things:
+ -- types, classes and implicit Ids
tcTyAndClassDecls unf_env this_mod decls
= sortByDependency decls `thenTc` \ groups ->
tcGroups unf_env this_mod []
= tcGetEnv `thenNF_Tc` \ env ->
- returnTc env
+ returnTc []
tcGroups unf_env this_mod (group:groups)
- = tcGroup unf_env this_mod group `thenTc` \ env ->
+ = tcGroup unf_env this_mod group `thenTc` \ (env, new_things1) ->
tcSetEnv env $
- tcGroups unf_env this_mod groups
+ tcGroups unf_env this_mod groups `thenTc` \ new_things2 ->
+ returnTc (new_things1 ++ new_things2)
\end{code}
Dealing with a group
@TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
\begin{code}
-tcGroup :: RecTcEnv -> Module -> SCC RenamedTyClDecl -> TcM TcEnv
+tcGroup :: RecTcEnv -> Module -> SCC RenamedTyClDecl
+ -> TcM (TcEnv, -- Input env extended by types and classes only
+ [TyThing]) -- Things defined by this group
+
tcGroup unf_env this_mod scc
- = getDOptsTc `thenTc` \ dflags ->
+ = getDOptsTc `thenNF_Tc` \ dflags ->
-- Step 1
mapNF_Tc getInitialKind decls `thenNF_Tc` \ initial_kinds ->
tyclss, all_tyclss :: [TyThing]
tyclss = map (buildTyConOrClass dflags is_rec kind_env
- rec_vrcs rec_details) decls
+ rec_vrcs rec_details) decls
-- Add the tycons that come from the classes
-- We want them in the environment because
-- they are mentioned in interface files
- all_tyclss = [ ATyCon (classTyCon clas) | AClass clas <- tyclss]
+ all_tyclss = [ATyCon (classTyCon clas) | AClass clas <- tyclss]
++ tyclss
-- Calculate variances, and (yes!) feed back into buildTyConOrClass.
-- Step 5
-- Extend the environment with the final
-- TyCons/Classes and check the decls
- tcExtendGlobalEnv all_tyclss $
- mapTc (tcTyClDecl1 unf_env) decls `thenTc` \ tycls_details ->
-
- -- Step 6
- -- Extend the environment with implicit Ids
- tcExtendGlobalValEnv (implicitTyThingIds all_tyclss) $
+ tcExtendGlobalEnv all_tyclss $
+ mapTc (tcTyClDecl1 unf_env) decls `thenTc` \ tycls_details ->
-- Return results
- tcGetEnv `thenNF_Tc` \ env ->
- returnTc (tycls_details, tyclss, env)
- ) `thenTc` \ (_, tyclss, env) ->
-
+ tcGetEnv `thenNF_Tc` \ env ->
+ returnTc (tycls_details, env, all_tyclss)
+ ) `thenTc` \ (_, env, all_tyclss) ->
-- Step 7: Check validity
traceTc (text "ready for validity check") `thenTc_`
) `thenTc_`
traceTc (text "done") `thenTc_`
- returnTc env
+ let
+ implicit_things = [AnId id | id <- implicitTyThingIds all_tyclss]
+ new_things = all_tyclss ++ implicit_things
+ in
+ returnTc (env, new_things)
where
is_rec = case scc of
CyclicSCC decls -> decls
tcTyClDecl1 unf_env decl
- | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 unf_env decl)
+ | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 decl)
| otherwise = tcAddDeclCtxt decl (tcTyDecl unf_env decl)
+-- We do the validity check over declarations, rather than TyThings
+-- only so that we can add a nice context with tcAddDeclCtxt
checkValidTyCl this_mod decl
= tcLookup (tcdName decl) `thenNF_Tc` \ (AGlobal thing) ->
if not (isLocalThing this_mod thing) then
kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
= kcTyClDeclBody decl $ \ result_kind ->
kcHsContext context `thenTc_`
- mapTc_ kc_con_decl con_decls
+ mapTc_ kc_con_decl (visibleDataCons con_decls)
where
kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
= kcHsTyVars ex_tvs `thenNF_Tc` \ kind_env ->
argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
- (TyData {tcdND = data_or_new, tcdName = tycon_name, tcdTyVars = tyvar_names,
- tcdNCons = nconstrs, tcdSysNames = sys_names})
+ (TyData {tcdND = data_or_new, tcdName = tycon_name,
+ tcdTyVars = tyvar_names, tcdSysNames = sys_names})
= ATyCon tycon
where
tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
- data_cons nconstrs sel_ids
+ data_cons sel_ids
flavour is_rec gen_info
+ -- It's not strictly necesary to mark newtypes as
+ -- recursive if the loop is broken via a data type.
+ -- But I'm not sure it's worth the hassle of discovering that.
gen_info | not (dopt Opt_Generics dflags) = Nothing
| otherwise = mkTyConGenInfo tycon sys_names
-- so flavour has to be able to answer this question without consulting rec_details
flavour = case data_or_new of
NewType -> NewTyCon (mkNewTyConRep tycon)
- DataType | all (null . dataConOrigArgTys) data_cons -> EnumTyCon
- | otherwise -> DataTyCon
+ DataType | all_nullary data_cons -> EnumTyCon
+ | otherwise -> DataTyCon
+
+ all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons
+ all_nullary other = False -- Safe choice for unknown data types
-- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon
-- but that looks at the *representation* arity, and that in turn
-- depends on deciding whether to unpack the args, and that
projects / ghc-hetmet.git / blobdiff