%
-% (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 (
- tcTyDecl1,
- kcConDetails,
- mkImplicitDataBinds, mkNewTyConRep
+module TcTyDecls(
+ calcTyConArgVrcs,
+ calcRecFlags,
+ calcClassCycles, calcSynCycles,
+ newTyConRhs
) where
#include "HsVersions.h"
-import HsSyn ( MonoBinds(..),
- TyClDecl(..), ConDecl(..), ConDetails(..), BangType(..),
- getBangType
- )
-import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext )
-import TcHsSyn ( TcMonoBinds, idsToMonoBinds )
-import BasicTypes ( NewOrData(..) )
-
-import TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType, tcHsTyVars, tcClassContext,
- kcHsContext, kcHsSigType
- )
-import TcEnv ( tcExtendTyVarEnv, tcLookupTy, tcLookupValueByKey, TyThing(..), TyThingDetails(..) )
-import TcMonad
-
-import Class ( ClassContext )
-import DataCon ( DataCon, mkDataCon,
- dataConFieldLabels, dataConId, dataConWrapId,
- markedStrict, notMarkedStrict, markedUnboxed, dataConRepType
- )
-import MkId ( mkDataConId, mkDataConWrapId, mkRecordSelId )
-import FieldLabel
-import Var ( Id, TyVar )
-import Name ( Name, isLocallyDefined, NamedThing(..) )
+import TypeRep ( Type(..), TyNote(..), PredType(..) ) -- friend
+import HsSyn ( TyClDecl(..), HsPred(..), LTyClDecl, isClassDecl )
+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(..), unLoc )
import Outputable
-import TyCon ( TyCon, isSynTyCon, isNewTyCon,
- tyConDataConsIfAvailable, tyConTyVars, tyConGenIds
- )
-import Type ( tyVarsOfTypes, splitFunTy, applyTys,
- mkTyConApp, mkTyVarTys, mkForAllTys,
- splitAlgTyConApp_maybe, Type
- )
-import TysWiredIn ( unitTy )
-import VarSet ( intersectVarSet, isEmptyVarSet )
-import PrelNames ( unpackCStringIdKey, unpackCStringUtf8IdKey )
-import ListSetOps ( equivClasses )
\end{code}
+
%************************************************************************
%* *
-\subsection{Type 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}
-tcTyDecl1 :: RenamedTyClDecl -> TcM s (Name, TyThingDetails)
-tcTyDecl1 (TySynonym tycon_name tyvar_names rhs src_loc)
- = tcLookupTy tycon_name `thenNF_Tc` \ (ATyCon tycon) ->
- tcExtendTyVarEnv (tyConTyVars tycon) $
- tcHsType rhs `thenTc` \ rhs_ty ->
- -- Note tcHsType not tcHsSigType; we allow type synonyms
- -- that aren't types; e.g. type List = []
- --
- -- If the RHS mentions tyvars that aren't in scope, we'll
- -- quantify over them:
- -- e.g. type T = a->a
- -- will become type T = forall a. a->a
- --
- -- With gla-exts that's right, but for H98 we should complain.
- -- We can now do that here without falling into
- -- a black hole, we still do it in rnDecl (TySynonym case)
-
- returnTc (tycon_name, SynTyDetails rhs_ty)
-
-tcTyDecl1 (TyData new_or_data context tycon_name _ con_decls _ derivings _ src_loc name1 name2)
- = tcLookupTy tycon_name `thenNF_Tc` \ (ATyCon tycon) ->
- let
- tyvars = tyConTyVars tycon
- in
- tcExtendTyVarEnv tyvars $
-
- -- Typecheck the pieces
- tcClassContext context `thenTc` \ ctxt ->
- tc_derivs derivings `thenTc` \ derived_classes ->
- mapTc (tcConDecl new_or_data tycon tyvars ctxt) con_decls `thenTc` \ data_cons ->
-
- returnTc (tycon_name, DataTyDetails ctxt data_cons derived_classes)
+calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
+calcSynCycles decls
+ = stronglyConnComp syn_edges
where
- tc_derivs Nothing = returnTc []
- tc_derivs (Just ds) = mapTc tc_deriv ds
+ syn_edges = [ (ldecl, unLoc (tcdLName decl),
+ mk_syn_edges (tcdSynRhs decl))
+ | ldecl@(L _ decl) <- decls ]
- tc_deriv name = tcLookupTy name `thenTc` \ (AClass clas) ->
- returnTc clas
-\end{code}
+ mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs),
+ not (isTyVarName tc) ]
-\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
-mkNewTyConRep tc
- = mkForAllTys tvs (loop [] (mkTyConApp tc (mkTyVarTys tvs)))
+calcClassCycles :: [LTyClDecl Name] -> [[LTyClDecl Name]]
+calcClassCycles decls
+ = [decls | CyclicSCC decls <- stronglyConnComp cls_edges]
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
- }
+ cls_edges = [ (ldecl, unLoc (tcdLName decl),
+ mk_cls_edges (unLoc (tcdCtxt decl)))
+ | ldecl@(L _ decl) <- decls, isClassDecl decl ]
+
+ mk_cls_edges ctxt = [ cls | L _ (HsClassP cls _) <- ctxt ]
\end{code}
%************************************************************************
%* *
-\subsection{Kind and type check constructors}
+ Deciding which type constructors are recursive
%* *
%************************************************************************
-\begin{code}
-kcConDetails :: RenamedContext -> ConDetails Name -> TcM s ()
-kcConDetails ex_ctxt details
- = kcHsContext ex_ctxt `thenTc_`
- kc_con_details details
- where
- kc_con_details (VanillaCon btys) = mapTc_ kc_bty btys
- kc_con_details (InfixCon bty1 bty2) = mapTc_ kc_bty [bty1,bty2]
- kc_con_details (RecCon flds) = mapTc_ kc_field flds
+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)
+
+(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
+
+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
+
+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.)
+
+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
- kc_field (_, bty) = kc_bty bty
+then we mark S as recursive, just in case. What that means is that if we see
- kc_bty bty = kcHsSigType (getBangType bty)
+ import Baz( S )
+ newtype R = MkR S
-tcConDecl :: NewOrData -> TyCon -> [TyVar] -> ClassContext -> RenamedConDecl -> TcM s DataCon
+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)
-tcConDecl new_or_data tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc)
- = tcAddSrcLoc src_loc $
- tcHsTyVars ex_tvs (kcConDetails ex_ctxt details) $ \ ex_tyvars ->
- tcClassContext ex_ctxt `thenTc` \ ex_theta ->
- case details of
- VanillaCon btys -> tc_datacon ex_tyvars ex_theta btys
- InfixCon bty1 bty2 -> tc_datacon ex_tyvars ex_theta [bty1,bty2]
- RecCon fields -> tc_rec_con ex_tyvars ex_theta fields
+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}
+calcRecFlags :: [TyThing] -> (Name -> RecFlag)
+calcRecFlags tyclss
+ = is_rec
where
- tc_sig_type = case new_or_data of
- DataType -> tcHsSigType
- NewType -> tcHsBoxedSigType
- -- Can't allow an unboxed type here, because we're effectively
- -- going to remove the constructor while coercing it to a boxed type.
-
- tc_datacon ex_tyvars ex_theta btys
- = let
- arg_stricts = map getBangStrictness btys
- tys = map getBangType btys
- in
- mapTc tc_sig_type tys `thenTc` \ arg_tys ->
- mk_data_con ex_tyvars ex_theta arg_stricts arg_tys []
-
- tc_rec_con ex_tyvars ex_theta fields
- = checkTc (null ex_tyvars) (exRecConErr name) `thenTc_`
- mapTc tc_field (fields `zip` allFieldLabelTags) `thenTc` \ field_labels_s ->
- let
- field_labels = concat field_labels_s
- arg_stricts = [str | (ns, bty) <- fields,
- let str = getBangStrictness bty,
- n <- ns -- One for each. E.g x,y,z :: !Int
- ]
- in
- mk_data_con ex_tyvars ex_theta arg_stricts
- (map fieldLabelType field_labels) field_labels
-
- tc_field ((field_label_names, bty), tag)
- = tc_sig_type (getBangType bty) `thenTc` \ field_ty ->
- returnTc [mkFieldLabel (getName name) tycon field_ty tag | name <- field_label_names]
-
- mk_data_con ex_tyvars ex_theta arg_stricts arg_tys fields
- = 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
- arg_tyvars = tyVarsOfTypes arg_tys
- in_arg_tys (clas,tys) = not $ isEmptyVarSet $
- tyVarsOfTypes tys `intersectVarSet` arg_tyvars
-
-getBangStrictness (Banged _) = markedStrict
-getBangStrictness (Unbanged _) = notMarkedStrict
-getBangStrictness (Unpacked _) = markedUnboxed
+ go edges = [ name
+ | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompR edges,
+ name <- tyConName tc : go edges']
\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 ++ gen_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
- gen_ids = tyConGenIds tycon
- data_con_wrapper_ids = map dataConWrapId data_cons
-
- fields = [ (con, field) | con <- data_cons,
- field <- dataConFieldLabels con
- ]
-
- -- groups is list of fields that share a common name
- groups = equivClasses cmp_name fields
- cmp_name (_, field1) (_, field2)
- = fieldLabelName field1 `compare` fieldLabelName field2
+ 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}
+
+Variance of tyvars in a type
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+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 ->
- tcLookupValueByKey unpackCStringUtf8IdKey `thenTc` \ unpackUtf8_id ->
- returnTc (mkRecordSelId tycon first_field_label unpack_id unpackUtf8_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}
projects / ghc-hetmet.git / blobdiff