import HsSyn ( TyClDecl(..),
ConDecl(..), Sig(..), HsPred(..),
tyClDeclName, hsTyVarNames, tyClDeclTyVars,
- isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig
+ isTypeOrClassDecl, isClassDecl, isSynDecl, isClassOpSig
)
import RnHsSyn ( RenamedTyClDecl, tyClDeclFVs )
import BasicTypes ( RecFlag(..), NewOrData(..) )
import Module ( Module )
import TcMonad
-import TcEnv ( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
- tcExtendKindEnv, tcLookup, tcExtendGlobalEnv, tcExtendGlobalValEnv,
+import TcEnv ( TcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
+ 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 ( 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,
)
The main function
~~~~~~~~~~~~~~~~~
\begin{code}
-tcTyAndClassDecls :: RecTcEnv -- Knot tying stuff
- -> Module -- Current module
+tcTyAndClassDecls :: Module -- Current module
-> [RenamedTyClDecl]
-> TcM [TyThing] -- Returns newly defined things:
-- types, classes and implicit Ids
-tcTyAndClassDecls unf_env this_mod decls
+tcTyAndClassDecls this_mod decls
= sortByDependency decls `thenTc` \ groups ->
- tcGroups unf_env this_mod groups
+ tcGroups this_mod groups
-tcGroups unf_env this_mod []
- = tcGetEnv `thenNF_Tc` \ env ->
- returnTc []
+tcGroups this_mod []
+ = returnTc []
-tcGroups unf_env this_mod (group:groups)
- = tcGroup unf_env this_mod group `thenTc` \ (env, new_things1) ->
- tcSetEnv env $
- tcGroups unf_env this_mod groups `thenTc` \ new_things2 ->
+tcGroups this_mod (group:groups)
+ = tcGroup this_mod group `thenTc` \ (env, new_things1) ->
+ tcSetEnv env $
+ tcGroups this_mod groups `thenTc` \ new_things2 ->
returnTc (new_things1 ++ new_things2)
\end{code}
@TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
\begin{code}
-tcGroup :: RecTcEnv -> Module -> SCC RenamedTyClDecl
+tcGroup :: 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
+tcGroup this_mod scc
= getDOptsTc `thenNF_Tc` \ dflags ->
-- Step 1
mapNF_Tc getInitialKind decls `thenNF_Tc` \ initial_kinds ->
-- 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 ->
+ tcExtendGlobalEnv all_tyclss $
+ mapTc tcTyClDecl1 decls `thenTc` \ tycls_details ->
-- Return results
- tcGetEnv `thenNF_Tc` \ env ->
+ tcGetEnv `thenNF_Tc` \ env ->
returnTc (tycls_details, env, all_tyclss)
) `thenTc` \ (_, env, all_tyclss) ->
AcyclicSCC decl -> [decl]
CyclicSCC decls -> decls
-tcTyClDecl1 unf_env decl
+tcTyClDecl1 decl
| isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 decl)
- | otherwise = tcAddDeclCtxt decl (tcTyDecl unf_env decl)
+ | otherwise = tcAddDeclCtxt decl (tcTyDecl decl)
-- We do the validity check over declarations, rather than TyThings
-- only so that we can add a nice context with tcAddDeclCtxt
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
in
returnTc decl_sccs
where
- tycl_decls = filter (not . isIfaceSigDecl) decls
+ tycl_decls = filter isTypeOrClassDecl decls
edges = map mkEdges tycl_decls
is_syn_decl (d, _, _) = isSynDecl d