%
-% (c) The AQUA Project, Glasgow University, 1996-1998
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1999
%
-\section[TcTyDecls]{Typecheck type declarations}
+
+Analysis functions over data types. Specficially
+ a) detecting recursive types
+ b) computing argument variances
+
+This stuff is only used for source-code decls; it's recorded in interface
+files for imported data types.
+
\begin{code}
-module TcTyDecls (
- tcTyDecl, kcTyDecl,
- tcConDecl,
- mkImplicitDataBinds, mkNewTyConRep
+module TcTyDecls(
+ calcTyConArgVrcs,
+ calcRecFlags, calcCycleErrs,
+ newTyConRhs
) where
#include "HsVersions.h"
-import HsSyn ( MonoBinds(..),
- TyClDecl(..), ConDecl(..), ConDetails(..), BangType(..),
- andMonoBindList
- )
-import RnHsSyn ( RenamedTyClDecl, RenamedConDecl )
-import TcHsSyn ( TcMonoBinds, idsToMonoBinds )
-import BasicTypes ( RecFlag(..), NewOrData(..) )
-
-import TcMonoType ( tcExtendTopTyVarScope, tcExtendTyVarScope,
- tcHsTypeKind, kcHsType, tcHsTopType, tcHsTopBoxedType,
- tcContext, tcHsTopTypeKind
- )
-import TcType ( zonkTcTyVarToTyVar, zonkTcClassConstraints )
-import TcEnv ( tcLookupTy, tcLookupValueByKey, TcTyThing(..) )
-import TcMonad
-import TcUnify ( unifyKind )
-
-import Class ( Class )
-import DataCon ( DataCon, mkDataCon, isNullaryDataCon,
- dataConFieldLabels, dataConId, dataConWrapId,
- markedStrict, notMarkedStrict, markedUnboxed, dataConRepType
- )
-import MkId ( mkDataConId, mkDataConWrapId, mkRecordSelId )
-import FieldLabel
-import Var ( Id, TyVar )
-import Name ( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique )
+import TypeRep ( Type(..), TyNote(..), PredType(..) ) -- friend
+import HsSyn ( TyClDecl(..), HsPred(..), LTyClDecl )
+import RnHsSyn ( extractHsTyNames )
+import Type ( predTypeRep )
+import BuildTyCl ( newTyConRhs )
+import HscTypes ( TyThing(..) )
+import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars,
+ getSynTyConDefn, isSynTyCon, isAlgTyCon, isHiBootTyCon,
+ tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs )
+import Class ( classTyCon )
+import DataCon ( dataConRepArgTys, dataConOrigArgTys )
+import Var ( TyVar )
+import VarSet
+import Name ( Name, isTyVarName )
+import NameEnv
+import NameSet
+import Digraph ( SCC(..), stronglyConnComp, stronglyConnCompR )
+import BasicTypes ( RecFlag(..) )
+import SrcLoc ( Located(..) )
import Outputable
-import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, mkSynTyCon, mkAlgTyCon,
- tyConDataConsIfAvailable, tyConTyVars,
- isSynTyCon, isNewTyCon
- )
-import Type ( getTyVar, tyVarsOfTypes, splitFunTy, applyTys,
- mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy,
- mkTyVarTy, splitAlgTyConApp_maybe,
- mkArrowKind, mkArrowKinds, boxedTypeKind,
- isUnboxedType, Type, ThetaType, classesOfPreds
- )
-import TysWiredIn ( unitTy )
-import Var ( tyVarKind )
-import VarSet ( intersectVarSet, isEmptyVarSet )
-import Unique ( unpackCStringIdKey )
-import Util ( equivClasses )
-import FiniteMap ( FiniteMap, lookupWithDefaultFM )
\end{code}
+
%************************************************************************
%* *
-\subsection{Kind checking}
+ Cycles in class and type synonym declarations
%* *
%************************************************************************
+We check for type synonym and class cycles on the *source* code.
+Main reasons:
+
+ a) Otherwise we'd need a special function to extract type-synonym tycons
+ from a type, whereas we have extractHsTyNames already
+
+ b) If we checked for type synonym loops after building the TyCon, we
+ can't do a hoistForAllTys on the type synonym rhs, (else we fall into
+ a black hole) which seems unclean. Apart from anything else, it'd mean
+ that a type-synonym rhs could have for-alls to the right of an arrow,
+ which means adding new cases to the validity checker
+
+ Indeed, in general, checking for cycles beforehand means we need to
+ be less careful about black holes through synonym cycles.
+
+The main disadvantage is that a cycle that goes via a type synonym in an
+.hi-boot file can lead the compiler into a loop, because it assumes that cycles
+only occur in source code. But hi-boot files are trusted anyway, so this isn't
+much worse than (say) a kind error.
+
+[ NOTE ----------------------------------------------
+If we reverse this decision, this comment came from tcTyDecl1, and should
+ go back there
+ -- dsHsType, not tcHsKindedType, to avoid a loop. tcHsKindedType does hoisting,
+ -- which requires looking through synonyms... and therefore goes into a loop
+ -- on (erroneously) recursive synonyms.
+ -- Solution: do not hoist synonyms, because they'll be hoisted soon enough
+ -- when they are substituted
+
+We'd also need to add back in this definition
+
+synTyConsOfType :: Type -> [TyCon]
+-- Does not look through type synonyms at all
+-- Return a list of synonym tycons
+synTyConsOfType ty
+ = nameEnvElts (go ty)
+ where
+ go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
+ go (TyVarTy v) = emptyNameEnv
+ go (TyConApp tc tys) = go_tc tc tys -- See note (a)
+ go (NewTcApp tc tys) = go_s tys -- Ignore tycon
+ go (AppTy a b) = go a `plusNameEnv` go b
+ go (FunTy a b) = go a `plusNameEnv` go b
+ go (PredTy (IParam _ ty)) = go ty
+ go (PredTy (ClassP cls tys)) = go_s tys -- Ignore class
+ go (NoteTy (SynNote ty) _) = go ty -- Don't look through it!
+ go (NoteTy other ty) = go ty
+ go (ForAllTy _ ty) = go ty
+
+ -- Note (a): the unexpanded branch of a SynNote has a
+ -- TyConApp for the synonym, so the tc of
+ -- a TyConApp must be tested for possible synonyms
+
+ go_tc tc tys | isSynTyCon tc = extendNameEnv (go_s tys) (tyConName tc) tc
+ | otherwise = go_s tys
+ go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
+---------------------------------------- END NOTE ]
+
\begin{code}
-kcTyDecl :: RenamedTyClDecl -> TcM s ()
-
-kcTyDecl (TySynonym name tyvar_names rhs src_loc)
- = tcLookupTy name `thenNF_Tc` \ (kind, _) ->
- tcExtendTopTyVarScope kind tyvar_names $ \ _ result_kind ->
- tcHsTypeKind rhs `thenTc` \ (rhs_kind, _) ->
- unifyKind result_kind rhs_kind
-
-kcTyDecl (TyData _ context tycon_name tyvar_names con_decls _ _ _ src_loc)
- = tcLookupTy tycon_name `thenNF_Tc` \ (kind, _) ->
- tcExtendTopTyVarScope kind tyvar_names $ \ result_kind _ ->
- tcContext context `thenTc_`
- mapTc kcConDecl con_decls `thenTc_`
- returnTc ()
-
-kcConDecl (ConDecl _ _ ex_tvs ex_ctxt details loc)
- = tcAddSrcLoc loc (
- tcExtendTyVarScope ex_tvs ( \ tyvars ->
- tcContext ex_ctxt `thenTc_`
- kc_con details `thenTc_`
- returnTc ()
- ))
+calcCycleErrs :: [LTyClDecl Name] -> ([[Name]], -- Recursive type synonym groups
+ [[Name]]) -- Ditto classes
+calcCycleErrs decls
+ = (findCyclics syn_edges, findCyclics cls_edges)
where
- kc_con (VanillaCon btys) = mapTc kc_bty btys `thenTc_` returnTc ()
- kc_con (InfixCon bty1 bty2) = mapTc kc_bty [bty1,bty2] `thenTc_` returnTc ()
- kc_con (NewCon ty _) = kcHsType ty
- kc_con (RecCon flds) = mapTc kc_field flds `thenTc_` returnTc ()
+ --------------- Type synonyms ----------------------
+ syn_edges = [ (name, mk_syn_edges rhs) |
+ L _ (TySynonym { tcdLName = L _ name,
+ tcdSynRhs = rhs }) <- decls ]
+
+ mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs),
+ not (isTyVarName tc) ]
- kc_bty (Banged ty) = kcHsType ty
- kc_bty (Unbanged ty) = kcHsType ty
- kc_bty (Unpacked ty) = kcHsType ty
+ --------------- Classes ----------------------
+ cls_edges = [ (name, mk_cls_edges ctxt) |
+ L _ (ClassDecl { tcdLName = L _ name,
+ tcdCtxt = L _ ctxt }) <- decls ]
- kc_field (_, bty) = kc_bty bty
+ mk_cls_edges ctxt = [ cls | L _ (HsClassP cls _) <- ctxt ]
\end{code}
%************************************************************************
%* *
-\subsection{Type checking}
+ Deciding which type constructors are recursive
%* *
%************************************************************************
-\begin{code}
-tcTyDecl :: RecFlag -> FiniteMap Name ArgVrcs -> RenamedTyClDecl -> TcM s (Name, TcTyThing)
-
-tcTyDecl is_rec rec_vrcs (TySynonym tycon_name tyvar_names rhs src_loc)
- = tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, ASynTyCon _ arity) ->
- tcExtendTopTyVarScope tycon_kind tyvar_names $ \ tyvars _ ->
- tcHsTopTypeKind rhs `thenTc` \ (_, rhs_ty) ->
- -- If the RHS mentions tyvars that aren't in scope, we'll
- -- quantify over them. With gla-exts that's right, but for H98
- -- we should complain. We can't do that here without falling into
- -- a black hole, so we do it in rnDecl (TySynonym case)
- let
- -- Construct the tycon
- argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name)
- tycon_name
- tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
- in
- returnTc (tycon_name, ASynTyCon tycon arity)
-
-
-tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_decls nconstrs derivings pragmas src_loc)
- = -- Lookup the pieces
- tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, ADataTyCon rec_tycon) ->
- tcExtendTopTyVarScope tycon_kind tyvar_names $ \ tyvars _ ->
-
- -- Typecheck the pieces
- tcContext context `thenTc` \ ctxt ->
- let ctxt' = classesOfPreds ctxt in
- mapTc (tcConDecl rec_tycon tyvars ctxt') con_decls `thenTc` \ data_cons ->
- tc_derivs derivings `thenTc` \ derived_classes ->
-
- let
- -- Construct the tycon
- flavour = case data_or_new of
- NewType -> NewTyCon (mkNewTyConRep tycon)
- DataType | all isNullaryDataCon data_cons -> EnumTyCon
- | otherwise -> DataTyCon
-
- argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name)
- tycon_name
-
- tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt' argvrcs
- data_cons nconstrs
- derived_classes
- flavour is_rec
- in
- returnTc (tycon_name, ADataTyCon tycon)
- where
- tc_derivs Nothing = returnTc []
- tc_derivs (Just ds) = mapTc tc_deriv ds
+A newtype M.T is defined to be "recursive" iff
+ (a) its rhs mentions an abstract (hi-boot) TyCon
+ or (b) one can get from T's rhs to T via type
+ synonyms, or non-recursive newtypes *in M*
+ e.g. newtype T = MkT (T -> Int)
- tc_deriv name = tcLookupTy name `thenTc` \ (_, AClass clas _) ->
- returnTc clas
-\end{code}
+(a) is conservative; it assumes that the hi-boot type can loop
+ around to T. That's why in (b) we can restrict attention
+ to tycons in M, because any loops through newtypes outside M
+ will be broken by those newtypes
-\begin{code}
-mkNewTyConRep :: TyCon -> Type
--- Find the representation type for this newtype TyCon
--- The trick is to to deal correctly with recursive newtypes
--- such as newtype T = MkT T
+An algebraic data type M.T is "recursive" iff
+ it has just one constructor, and
+ (a) its arg types mention an abstract (hi-boot) TyCon
+ or (b) one can get from its arg types to T via type synonyms,
+ or by non-recursive newtypes or non-recursive product types in M
+ e.g. data T = MkT (T -> Int) Bool
-mkNewTyConRep tc
- = mkForAllTys tvs (loop [] (mkTyConApp tc (mkTyVarTys tvs)))
- where
- tvs = tyConTyVars tc
- loop tcs ty = case splitAlgTyConApp_maybe ty of {
- Nothing -> ty ;
- Just (tc, tys, data_cons) | not (isNewTyCon tc) -> ty
- | tc `elem` tcs -> unitTy
- | otherwise ->
-
- case splitFunTy (applyTys (dataConRepType (head data_cons)) tys) of
- (rep_ty, _) -> loop (tc:tcs) rep_ty
- }
-\end{code}
+A type synonym is recursive if one can get from its
+right hand side back to it via type synonyms. (This is
+reported as an error.)
+A class is recursive if one can get from its superclasses
+back to it. (This is an error too.)
-%************************************************************************
-%* *
-\subsection{Type check constructors}
-%* *
-%************************************************************************
+Hi-boot types
+~~~~~~~~~~~~~
+A data type read from an hi-boot file will have an Unknown in its data constructors,
+and will respond True to isHiBootTyCon. The idea is that we treat these as if one
+could get from these types to anywhere. So when we see
+
+ module Baz where
+ import {-# SOURCE #-} Foo( T )
+ newtype S = MkS T
+
+then we mark S as recursive, just in case. What that means is that if we see
+
+ import Baz( S )
+ newtype R = MkR S
+
+then we don't need to look inside S to compute R's recursiveness. Since S is imported
+(not from an hi-boot file), one cannot get from R back to S except via an hi-boot file,
+and that means that some data type will be marked recursive along the way. So R is
+unconditionly non-recursive (i.e. there'll be a loop breaker elsewhere if necessary)
+
+This in turn means that we grovel through fewer interface files when computing
+recursiveness, because we need only look at the type decls in the module being
+compiled, plus the outer structure of directly-mentioned types.
\begin{code}
-tcConDecl :: TyCon -> [TyVar] -> [(Class,[Type])] -> RenamedConDecl -> TcM s DataCon
-
-tcConDecl tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc)
- = tcAddSrcLoc src_loc $
- tcExtendTyVarScope ex_tvs $ \ ex_tyvars ->
- tcContext ex_ctxt `thenTc` \ ex_theta ->
- let
- ex_ctxt' = classesOfPreds ex_theta
- in
- tc_con_decl_help tycon tyvars ctxt name wkr_name ex_tyvars ex_ctxt' details
-
-tc_con_decl_help tycon tyvars ctxt name wkr_name ex_tyvars ex_theta details
- = case details of
- VanillaCon btys -> tc_datacon btys
- InfixCon bty1 bty2 -> tc_datacon [bty1,bty2]
- NewCon ty mb_f -> tc_newcon ty mb_f
- RecCon fields -> tc_rec_con fields
+calcRecFlags :: [TyThing] -> (Name -> RecFlag)
+calcRecFlags tyclss
+ = is_rec
where
- tc_datacon btys
- = let
- arg_stricts = map get_strictness btys
- tys = map get_pty btys
- in
- mapTc tcHsTopType tys `thenTc` \ arg_tys ->
- mk_data_con arg_stricts arg_tys []
-
- tc_newcon ty mb_f
- = tcHsTopBoxedType ty `thenTc` \ arg_ty ->
- -- can't allow an unboxed type here, because we're effectively
- -- going to remove the constructor while coercing it to a boxed type.
- let
- field_label =
- case mb_f of
- Nothing -> []
- Just f -> [mkFieldLabel (getName f) tycon arg_ty (head allFieldLabelTags)]
- in
- mk_data_con [notMarkedStrict] [arg_ty] field_label
-
- tc_rec_con fields
- = checkTc (null ex_tyvars) (exRecConErr name) `thenTc_`
- mapTc tc_field fields `thenTc` \ field_label_infos_s ->
- let
- field_label_infos = concat field_label_infos_s
- arg_stricts = [strict | (_, _, strict) <- field_label_infos]
- arg_tys = [ty | (_, ty, _) <- field_label_infos]
-
- field_labels = [ mkFieldLabel (getName name) tycon ty tag
- | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
- in
- mk_data_con arg_stricts arg_tys field_labels
-
- tc_field (field_label_names, bty)
- = tcHsTopType (get_pty bty) `thenTc` \ field_ty ->
- returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
-
- mk_data_con arg_stricts arg_tys fields
- = -- Now we've checked all the field types we must
- -- zonk the existential tyvars to finish the kind
- -- inference on their kinds, and commit them to being
- -- immutable type variables. (The top-level tyvars are
- -- already fixed, by the preceding kind-inference pass.)
- mapNF_Tc zonkTcTyVarToTyVar ex_tyvars `thenNF_Tc` \ ex_tyvars' ->
- zonkTcClassConstraints ex_theta `thenNF_Tc` \ ex_theta' ->
- let
- data_con = mkDataCon name arg_stricts fields
- tyvars (thinContext arg_tys ctxt)
- ex_tyvars' ex_theta'
- arg_tys
- tycon data_con_id data_con_wrap_id
- data_con_id = mkDataConId wkr_name data_con
- data_con_wrap_id = mkDataConWrapId data_con
- in
- returnNF_Tc data_con
-
--- The context for a data constructor should be limited to
--- the type variables mentioned in the arg_tys
-thinContext arg_tys ctxt
- = filter in_arg_tys ctxt
+ is_rec n | n `elemNameSet` rec_names = Recursive
+ | otherwise = NonRecursive
+
+ rec_names = nt_loop_breakers `unionNameSets` prod_loop_breakers
+
+ all_tycons = map getTyCon tyclss -- Recursion of newtypes/data types
+ -- can happen via the class TyCon
+
+ -------------------------------------------------
+ -- NOTE
+ -- These edge-construction loops rely on
+ -- every loop going via tyclss, the types and classes
+ -- in the module being compiled. Stuff in interface
+ -- files should be correctly marked. If not (e.g. a
+ -- type synonym in a hi-boot file) we can get an infinite
+ -- loop. We could program round this, but it'd make the code
+ -- rather less nice, so I'm not going to do that yet.
+
+ --------------- Newtypes ----------------------
+ new_tycons = filter isNewTyCon all_tycons
+ nt_loop_breakers = mkNameSet (findLoopBreakers nt_edges)
+ is_rec_nt tc = tyConName tc `elemNameSet` nt_loop_breakers
+ -- is_rec_nt is a locally-used helper function
+
+ nt_edges = [(t, mk_nt_edges t) | t <- new_tycons]
+
+ mk_nt_edges nt -- Invariant: nt is a newtype
+ = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (newTyConRhs nt))
+ -- tyConsOfType looks through synonyms
+
+ mk_nt_edges1 nt tc
+ | tc `elem` new_tycons = [tc] -- Loop
+ | isHiBootTyCon tc = [nt] -- Make it self-recursive if
+ -- it mentions an hi-boot TyCon
+ -- At this point we know that either it's a local data type,
+ -- or it's imported. Either way, it can't form part of a cycle
+ | otherwise = []
+
+ --------------- Product types ----------------------
+ -- The "prod_tycons" are the non-newtype products
+ prod_tycons = [tc | tc <- all_tycons,
+ not (isNewTyCon tc), isProductTyCon tc]
+ prod_loop_breakers = mkNameSet (findLoopBreakers prod_edges)
+
+ prod_edges = [(tc, mk_prod_edges tc) | tc <- prod_tycons]
+
+ mk_prod_edges tc -- Invariant: tc is a product tycon
+ = concatMap (mk_prod_edges1 tc) (dataConOrigArgTys (head (tyConDataCons tc)))
+
+ mk_prod_edges1 ptc ty = concatMap (mk_prod_edges2 ptc) (tcTyConsOfType ty)
+
+ mk_prod_edges2 ptc tc
+ | tc `elem` prod_tycons = [tc] -- Local product
+ | tc `elem` new_tycons = if is_rec_nt tc -- Local newtype
+ then []
+ else mk_prod_edges1 ptc (newTyConRhs tc)
+ | isHiBootTyCon tc = [ptc] -- Make it self-recursive if
+ -- it mentions an hi-boot TyCon
+ -- At this point we know that either it's a local non-product data type,
+ -- or it's imported. Either way, it can't form part of a cycle
+ | otherwise = []
+
+getTyCon (ATyCon tc) = tc
+getTyCon (AClass cl) = classTyCon cl
+
+findLoopBreakers :: [(TyCon, [TyCon])] -> [Name]
+-- Finds a set of tycons that cut all loops
+findLoopBreakers deps
+ = go [(tc,tc,ds) | (tc,ds) <- deps]
+ where
+ go edges = [ name
+ | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompR edges,
+ name <- tyConName tc : go edges']
+
+findCyclics :: [(Name,[Name])] -> [[Name]]
+findCyclics deps
+ = [names | CyclicSCC names <- stronglyConnComp edges]
where
- arg_tyvars = tyVarsOfTypes arg_tys
- in_arg_tys (clas,tys) = not $ isEmptyVarSet $
- tyVarsOfTypes tys `intersectVarSet` arg_tyvars
-
-get_strictness (Banged _) = markedStrict
-get_strictness (Unbanged _) = notMarkedStrict
-get_strictness (Unpacked _) = markedUnboxed
-
-get_pty (Banged ty) = ty
-get_pty (Unbanged ty) = ty
-get_pty (Unpacked ty) = ty
+ edges = [(name,name,ds) | (name,ds) <- deps]
\end{code}
+These two functions know about type representations, so they could be
+in Type or TcType -- but they are very specialised to this module, so
+I've chosen to put them here.
+
+\begin{code}
+tcTyConsOfType :: Type -> [TyCon]
+-- tcTyConsOfType looks through all synonyms, but not through any newtypes.
+-- When it finds a Class, it returns the class TyCon. The reaons it's here
+-- (not in Type.lhs) is because it is newtype-aware.
+tcTyConsOfType ty
+ = nameEnvElts (go ty)
+ where
+ go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
+ go (TyVarTy v) = emptyNameEnv
+ go (TyConApp tc tys) = go_tc tc tys
+ go (NewTcApp tc tys) = go_tc tc tys
+ go (AppTy a b) = go a `plusNameEnv` go b
+ go (FunTy a b) = go a `plusNameEnv` go b
+ go (PredTy (IParam _ ty)) = go ty
+ go (PredTy (ClassP cls tys)) = go_tc (classTyCon cls) tys
+ go (NoteTy _ ty) = go ty
+ go (ForAllTy _ ty) = go ty
+
+ go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
+ go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
+\end{code}
%************************************************************************
%* *
-\subsection{Generating constructor/selector bindings for data declarations}
+ Compuing TyCon argument variances
%* *
%************************************************************************
+Computing the tyConArgVrcs info
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+@tyConArgVrcs@ gives a list of (occPos,occNeg) flags, one for each
+tyvar. For @AlgTyCon@s and @SynTyCon@s, this info must be precomputed
+separately. Note that this is information about occurrences of type
+variables, not usages of term variables.
+
+The function @calcTyConArgVrcs@ must be passed a list of *algebraic or
+syntycons only* such that all tycons referred to (by mutual recursion)
+appear in the list. The fixpointing will be done on this set of
+tycons as a whole. It returns a list of @tyconVrcInfo@ data, ready to
+be (knot-tyingly?) stuck back into the appropriate fields.
+
\begin{code}
-mkImplicitDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds)
-mkImplicitDataBinds [] = returnTc ([], EmptyMonoBinds)
-mkImplicitDataBinds (tycon : tycons)
- | isSynTyCon tycon = mkImplicitDataBinds tycons
- | otherwise = mkImplicitDataBinds_one tycon `thenTc` \ (ids1, b1) ->
- mkImplicitDataBinds tycons `thenTc` \ (ids2, b2) ->
- returnTc (ids1++ids2, b1 `AndMonoBinds` b2)
-
-mkImplicitDataBinds_one tycon
- = mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids ->
- let
- unf_ids = sel_ids ++ data_con_wrapper_ids
- all_ids = map dataConId data_cons ++ unf_ids
-
- -- For the locally-defined things
- -- we need to turn the unfoldings inside the selector Ids into bindings,
- -- and build bindigns for the constructor wrappers
- binds | isLocallyDefined tycon = idsToMonoBinds unf_ids
- | otherwise = EmptyMonoBinds
- in
- returnTc (all_ids, binds)
+calcTyConArgVrcs :: [TyThing] -> Name -> ArgVrcs
+-- Gives arg variances for TyCons,
+-- including the class TyCon of a class
+calcTyConArgVrcs tyclss
+ = get_vrc
where
- data_cons = tyConDataConsIfAvailable tycon
- -- Abstract types mean we don't bring the
- -- data cons into scope, which should be fine
+ tycons = map getTyCon tyclss
+
+ -- We should only look up things that are in the map
+ get_vrc n = case lookupNameEnv final_oi n of
+ Just (_, pms) -> pms
+ Nothing -> pprPanic "calcVrcs" (ppr n)
+
+ -- We are going to fold over this map,
+ -- so we need the TyCon in the range
+ final_oi :: NameEnv (TyCon, ArgVrcs)
+ final_oi = tcaoFix initial_oi
+
+ initial_oi :: NameEnv (TyCon, ArgVrcs)
+ initial_oi = mkNameEnv [(tyConName tc, (tc, initial tc))
+ | tc <- tycons]
+ initial tc = replicate (tyConArity tc) (False,False)
+
+ tcaoFix :: NameEnv (TyCon, ArgVrcs) -- initial ArgVrcs per tycon
+ -> NameEnv (TyCon, ArgVrcs) -- fixpointed ArgVrcs per tycon
+ tcaoFix oi
+ | changed = tcaoFix oi'
+ | otherwise = oi'
+ where
+ (changed,oi') = foldNameEnv iterate (False,oi) oi
+
+ iterate (tc, pms) (changed,oi')
+ = (changed || (pms /= pms'),
+ extendNameEnv oi' (tyConName tc) (tc, pms'))
+ where
+ pms' = tcaoIter oi' tc -- seq not simult
+
+ tcaoIter :: NameEnv (TyCon, ArgVrcs) -- reference ArgVrcs (initial)
+ -> TyCon -- tycon to update
+ -> ArgVrcs -- new ArgVrcs for tycon
+
+ tcaoIter oi tc | isAlgTyCon tc
+ = map (\v -> anyVrc (vrcInTy (lookup oi) v) argtys) vs
+ where
+ data_cons = tyConDataCons tc
+ vs = tyConTyVars tc
+ argtys = concatMap dataConRepArgTys data_cons -- Rep? or Orig?
+
+ tcaoIter oi tc | isSynTyCon tc
+ = let (tyvs,ty) = getSynTyConDefn tc
+ -- we use the already-computed result for tycons not in this SCC
+ in map (\v -> vrcInTy (lookup oi) v ty) tyvs
+
+ lookup oi tc = case lookupNameEnv oi (tyConName tc) of
+ Just (_, pms) -> pms
+ Nothing -> tyConArgVrcs tc
+ -- We use the already-computed result for tycons not in this SCC
+\end{code}
- data_con_wrapper_ids = map dataConWrapId data_cons
- fields = [ (con, field) | con <- data_cons,
- field <- dataConFieldLabels con
- ]
+Variance of tyvars in a type
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- -- groups is list of fields that share a common name
- groups = equivClasses cmp_name fields
- cmp_name (_, field1) (_, field2)
- = fieldLabelName field1 `compare` fieldLabelName field2
-\end{code}
+A general variance-check function. We pass a function for determining
+the @ArgVrc@s of a tycon; when fixpointing this refers to the current
+value; otherwise this should be looked up from the tycon's own
+tyConArgVrcs. Again, it knows the representation of Types.
\begin{code}
-mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
- -- These fields all have the same name, but are from
- -- different constructors in the data type
- -- Check that all the fields in the group have the same type
- -- This check assumes that all the constructors of a given
- -- data type use the same type variables
- = checkTc (all (== field_ty) other_tys)
- (fieldTypeMisMatch field_name) `thenTc_`
- tcLookupValueByKey unpackCStringIdKey `thenTc` \ unpack_id ->
- returnTc (mkRecordSelId tycon first_field_label unpack_id)
- where
- field_ty = fieldLabelType first_field_label
- field_name = fieldLabelName first_field_label
- other_tys = [fieldLabelType fl | (_, fl) <- other_fields]
+vrcInTy :: (TyCon -> ArgVrcs) -- function to get argVrcs of a tycon (break out of recursion)
+ -> TyVar -- tyvar to check Vrcs of
+ -> Type -- type to check for occ in
+ -> (Bool,Bool) -- (occurs positively, occurs negatively)
+
+vrcInTy fao v (NoteTy (SynNote _) ty) = vrcInTy fao v ty
+ -- SynTyCon doesn't neccessarily have vrcInfo at this point,
+ -- so don't try and use it
+
+vrcInTy fao v (NoteTy (FTVNote ftv) ty) = if elemVarSet v ftv
+ then vrcInTy fao v ty
+ else (False,False)
+ -- note that ftv cannot be calculated as occPos||occNeg,
+ -- since if a tyvar occurs only as unused tyconarg,
+ -- occPos==occNeg==False, but ftv=True
+
+vrcInTy fao v (TyVarTy v') = if v==v'
+ then (True,False)
+ else (False,False)
+
+vrcInTy fao v (AppTy ty1 ty2) = if vrcInTy fao v ty2 /= (False,False)
+ then (True,True)
+ else vrcInTy fao v ty1
+ -- ty1 is probably unknown (or it would have been beta-reduced);
+ -- hence if v occurs in ty2 at all then it could occur with
+ -- either variance. Otherwise it occurs as it does in ty1.
+
+vrcInTy fao v (FunTy ty1 ty2) = negVrc (vrcInTy fao v ty1)
+ `orVrc`
+ vrcInTy fao v ty2
+
+vrcInTy fao v (ForAllTy v' ty) = if v==v'
+ then (False,False)
+ else vrcInTy fao v ty
+
+vrcInTy fao v (TyConApp tc tys) = let pms1 = map (vrcInTy fao v) tys
+ pms2 = fao tc
+ in orVrcs (zipWith timesVrc pms1 pms2)
+
+vrcInTy fao v (NewTcApp tc tys) = let pms1 = map (vrcInTy fao v) tys
+ pms2 = fao tc
+ in orVrcs (zipWith timesVrc pms1 pms2)
+
+vrcInTy fao v (PredTy st) = vrcInTy fao v (predTypeRep st)
\end{code}
+Variance algebra
+~~~~~~~~~~~~~~~~
-Errors and contexts
-~~~~~~~~~~~~~~~~~~~
\begin{code}
-fieldTypeMisMatch field_name
- = sep [ptext SLIT("Declared types differ for field"), quotes (ppr field_name)]
+orVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
+orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2)
+
+orVrcs :: [(Bool,Bool)] -> (Bool,Bool)
+orVrcs = foldl orVrc (False,False)
+
+negVrc :: (Bool,Bool) -> (Bool,Bool)
+negVrc (p1,m1) = (m1,p1)
+
+anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool)
+anyVrc p as = foldl (\ pm a -> pm `orVrc` p a)
+ (False,False) as
-exRecConErr name
- = ptext SLIT("Can't combine named fields with locally-quantified type variables")
- $$
- (ptext SLIT("In the declaration of data constructor") <+> ppr name)
+timesVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
+timesVrc (p1,m1) (p2,m2) = (p1 && p2 || m1 && m2,
+ p1 && m2 || m1 && p2)
\end{code}