%
-% (c) The AQUA Project, Glasgow University, 1996
+% (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,
- tcConDecl,
- mkDataBinds
+module TcTyDecls(
+ calcTyConArgVrcs,
+ calcRecFlags,
+ calcClassCycles, calcSynCycles
) where
#include "HsVersions.h"
-import HsSyn ( MonoBinds(..),
- TyDecl(..), ConDecl(..), ConDetails(..), BangType(..),
- andMonoBinds
- )
-import HsTypes ( getTyVarName )
-import RnHsSyn ( RenamedTyDecl, RenamedConDecl )
-import TcHsSyn ( mkHsTyLam, mkHsDictLam, tcIdType,
- TcHsBinds, TcMonoBinds
- )
-import BasicTypes ( RecFlag(..), NewOrData(..) )
-
-import Inst ( newDicts, InstOrigin(..), Inst )
-import TcMonoType ( tcHsTypeKind, tcHsType, tcContext )
-import TcSimplify ( tcSimplifyCheckThetas )
-import TcType ( tcInstTyVars )
-import TcEnv ( TcIdOcc(..), tcInstId,
- tcLookupTyCon, tcLookupTyVar, tcLookupClass,
- newLocalId, newLocalIds, tcLookupClassByKey
- )
-import TcMonad
-import TcKind ( TcKind, unifyKind, mkArrowKind, mkBoxedTypeKind )
-
-import Class ( classInstEnv, Class )
-import MkId ( mkDataCon, mkRecordSelId )
-import Id ( dataConSig, idType,
- dataConFieldLabels, dataConStrictMarks,
- StrictnessMark(..), getIdUnfolding,
- Id
- )
-import CoreUnfold ( getUnfoldingTemplate )
-import FieldLabel
-import Kind ( Kind, mkArrowKind, mkBoxedTypeKind )
-import Name ( nameSrcLoc, isLocallyDefined, getSrcLoc,
- OccName(..),
- NamedThing(..)
- )
+import TypeRep ( Type(..), TyNote(..), PredType(..) ) -- friend
+import HsSyn ( TyClDecl(..), HsPred(..), LTyClDecl, isClassDecl )
+import RnHsSyn ( extractHsTyNames )
+import Type ( predTypeRep )
+import HscTypes ( TyThing(..) )
+import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars,
+ getSynTyConDefn, isSynTyCon, isAlgTyCon, isHiBootTyCon,
+ tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs, newTyConRhs )
+import Class ( classTyCon )
+import DataCon ( 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, mkSynTyCon, mkDataTyCon, isAlgTyCon,
- isSynTyCon, tyConDataCons
- )
-import Type ( typeKind, getTyVar, tyVarsOfTypes, splitSigmaTy,
- mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy,
- splitFunTys, mkTyVarTy, getTyVar_maybe,
- isUnboxedType, Type, ThetaType
- )
-import TyVar ( tyVarKind, elementOfTyVarSet, intersectTyVarSets, isEmptyTyVarSet,
- TyVar )
-import Unique ( evalClassKey )
-import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet )
-import Util ( equivClasses, zipEqual, nOfThem, panic, assertPanic )
\end{code}
-\begin{code}
-tcTyDecl :: RecFlag -> RenamedTyDecl -> TcM s TyCon
-\end{code}
-Type synonym decls
-~~~~~~~~~~~~~~~~~~
+%************************************************************************
+%* *
+ Cycles in class and type synonym declarations
+%* *
+%************************************************************************
+
+Checking for class-decl loops is easy, because we don't allow class decls
+in interface files.
+
+We allow type synonyms in hi-boot files, but we *trust* hi-boot files,
+so we don't check for loops that involve them. So we only look for synonym
+loops in the module being compiled.
+
+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 entirely within the source code of the module being compiled.
+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 (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}
-tcTyDecl is_rec (TySynonym tycon_name tyvar_names rhs src_loc)
- = tcAddSrcLoc src_loc $
- tcAddErrCtxt (tySynCtxt tycon_name) $
-
- -- Look up the pieces
- tcLookupTyCon tycon_name `thenTc` \ (tycon_kind, _, rec_tycon) ->
- mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName) tyvar_names
- `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
-
- -- Look at the rhs
- tcHsTypeKind rhs `thenTc` \ (rhs_kind, rhs_ty) ->
-
- -- Unify tycon kind with (k1->...->kn->rhs)
- unifyKind tycon_kind
- (foldr mkArrowKind rhs_kind tyvar_kinds)
- `thenTc_`
- let
- -- Getting the TyCon's kind is a bit of a nuisance. We can't use the tycon_kind,
- -- because that's a TcKind and may not yet be fully unified with other kinds.
- -- We could have augmented the tycon environment with a knot-tied kind,
- -- but the simplest thing to do seems to be to get the Kind by (lazily)
- -- looking at the tyvars and rhs_ty.
- result_kind, final_tycon_kind :: Kind -- NB not TcKind!
- result_kind = typeKind rhs_ty
- final_tycon_kind = foldr (mkArrowKind . tyVarKind) result_kind rec_tyvars
-
- -- Construct the tycon
- tycon = mkSynTyCon (getName tycon_name)
- final_tycon_kind
- (length tyvar_names)
- rec_tyvars
- rhs_ty
- in
- returnTc tycon
-\end{code}
-
-Algebraic data and newtype decls
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
+calcSynCycles decls
+ = stronglyConnComp syn_edges
+ where
+ syn_edges = [ (ldecl, unLoc (tcdLName decl),
+ mk_syn_edges (tcdSynRhs decl))
+ | ldecl@(L _ decl) <- decls ]
-\begin{code}
-tcTyDecl is_rec (TyData data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc)
- = tcAddSrcLoc src_loc $
- let ctxt = case data_or_new of
- NewType -> tyNewCtxt tycon_name
- DataType -> tyDataCtxt tycon_name
- in
- tcAddErrCtxt ctxt $
-
- -- Lookup the pieces
- tcLookupTyCon tycon_name `thenTc` \ (tycon_kind, _, rec_tycon) ->
- mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName)
- tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
- tc_derivs derivings `thenTc` \ derived_classes ->
-
- -- Typecheck the context
- tcContext context `thenTc` \ ctxt ->
-
- -- Unify tycon kind with (k1->...->kn->Type)
- unifyKind tycon_kind
- (foldr mkArrowKind mkBoxedTypeKind tyvar_kinds)
- `thenTc_`
-
- -- Walk the condecls
- mapTc (tcConDecl rec_tycon rec_tyvars ctxt) con_decls
- `thenTc` \ con_ids ->
- let
- -- Construct the tycon
- final_tycon_kind :: Kind -- NB not TcKind!
- final_tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind rec_tyvars
-
- tycon = mkDataTyCon (getName tycon_name)
- final_tycon_kind
- rec_tyvars
- ctxt
- con_ids
- derived_classes
- Nothing -- Not a dictionary
- data_or_new
- is_rec
- in
- returnTc tycon
-
-tc_derivs Nothing = returnTc []
-tc_derivs (Just ds) = mapTc tc_deriv ds
-
-tc_deriv name
- = tcLookupClass name `thenTc` \ (_, clas) ->
- returnTc clas
-\end{code}
+ mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs),
+ not (isTyVarName tc) ]
-Generating constructor/selector bindings for data declarations
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-\begin{code}
-mkDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds s)
-mkDataBinds [] = returnTc ([], EmptyMonoBinds)
-mkDataBinds (tycon : tycons)
- | isSynTyCon tycon = mkDataBinds tycons
- | otherwise = mkDataBinds_one tycon `thenTc` \ (ids1, b1) ->
- mkDataBinds tycons `thenTc` \ (ids2, b2) ->
- returnTc (ids1++ids2, b1 `AndMonoBinds` b2)
-
-mkDataBinds_one tycon
- = ASSERT( isAlgTyCon tycon )
- mapTc checkConstructorContext data_cons `thenTc_`
- mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids ->
- let
- data_ids = data_cons ++ sel_ids
-
- -- For the locally-defined things
- -- we need to turn the unfoldings inside the Ids into bindings,
- binds = [ CoreMonoBind (RealId data_id) (getUnfoldingTemplate (getIdUnfolding data_id))
- | data_id <- data_ids, isLocallyDefined data_id
- ]
- in
- returnTc (data_ids, andMonoBinds binds)
+calcClassCycles :: [LTyClDecl Name] -> [[LTyClDecl Name]]
+calcClassCycles decls
+ = [decls | CyclicSCC decls <- stronglyConnComp cls_edges]
where
- data_cons = tyConDataCons tycon
- 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
+ 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}
--- Check that all the types of all the strict arguments are in Eval
+
+%************************************************************************
+%* *
+ Deciding which type constructors are recursive
+%* *
+%************************************************************************
+
+For newtypes, we label some as "recursive" such that
+
+ INVARIANT: there is no cycle of non-recursive newtypes
+
+In any loop, only one newtype need be marked as recursive; it is
+a "loop breaker". Labelling more than necessary as recursive is OK,
+provided the invariant is maintained.
+
+A newtype M.T is defined to be "recursive" iff
+ (a) it is declared in an hi-boot file (see RdrHsSyn.hsIfaceDecl)
+ (b) it is declared in a source file, but that source file has a
+ companion hi-boot file which declares the type
+ or (c) 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; declarations in hi-boot files are always
+ made loop breakers. 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
+(b) ensures that a newtype is not treated as a loop breaker in one place
+and later as a non-loop-breaker. This matters in GHCi particularly, when
+a newtype T might be embedded in many types in the environment, and then
+T's source module is compiled. We don't want T's recursiveness to change.
+
+The "recursive" flag for algebraic data types is irrelevant (never consulted)
+for types with more than one constructor.
+
+An algebraic data type M.T is "recursive" iff
+ it has just one constructor, and
+ (a) it is declared in an hi-boot file (see RdrHsSyn.hsIfaceDecl)
+ (b) it is declared in a source file, but that source file has a
+ companion hi-boot file which declares the type
+ or (c) 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
+Just like newtype in fact
+
+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 AbstractTyCon as its AlgTyConRhs
+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}
-checkConstructorContext con_id
- | not (isLocallyDefined con_id)
- = returnTc ()
-
- | otherwise -- It is locally defined
- = tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
- let
- strict_marks = dataConStrictMarks con_id
- (tyvars, theta, ext_tyvars, ext_theta, arg_tys, _) = dataConSig con_id
-
- eval_theta = [ (eval_clas, [arg_ty])
- | (arg_ty, MarkedStrict) <- zipEqual "strict_args"
- arg_tys strict_marks
- ]
- in
- tcAddErrCtxt (evalCtxt con_id eval_theta) $
- tcSimplifyCheckThetas theta eval_theta
+calcRecFlags :: [Name] -> [TyThing] -> (Name -> RecFlag)
+-- The 'boot_names' are the things declared in M.hi-boot, if M is the current module.
+-- Any type constructors in boot_names are automatically considered loop breakers
+calcRecFlags boot_names tyclss
+ = is_rec
+ where
+ is_rec n | n `elemNameSet` rec_names = Recursive
+ | otherwise = NonRecursive
+
+ boot_name_set = mkNameSet boot_names
+ rec_names = boot_name_set `unionNameSets`
+ nt_loop_breakers `unionNameSets`
+ prod_loop_breakers
+
+ all_tycons = [ tc | tycls <- tyclss,
+ -- Recursion of newtypes/data types can happen via
+ -- the class TyCon, so tyclss includes the class tycons
+ let tc = getTyCon tycls,
+ not (tyConName tc `elemNameSet` boot_name_set) ]
+ -- Remove the boot_name_set because they are going
+ -- to be loop breakers regardless.
+
+ -------------------------------------------------
+ -- 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 (new_tc_rhs nt))
+ -- tyConsOfType looks through synonyms
+
+ mk_nt_edges1 nt tc
+ | tc `elem` new_tycons = [tc] -- Loop
+ -- 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 newtype 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 (new_tc_rhs tc)
+ -- 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 = []
+
+new_tc_rhs tc = snd (newTyConRhs tc) -- Ignore the type variables
+
+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']
\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}
-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_`
- returnTc selector_id
+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
- field_ty = fieldLabelType first_field_label
- field_name = fieldLabelName first_field_label
- other_tys = [fieldLabelType fl | (_, fl) <- other_fields]
- (tyvars, _, _, _, _, _) = dataConSig first_con
- data_ty = mkTyConApp tycon (mkTyVarTys tyvars)
- -- tyvars of first_con may be free in field_ty
- -- Now build the selector
-
- selector_ty :: Type
- selector_ty = mkForAllTys tyvars $
- mkFunTy data_ty $
- field_ty
-
- selector_id :: Id
- selector_id = mkRecordSelId first_field_label selector_ty
+ go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
+ go (TyVarTy v) = emptyNameEnv
+ go (TyConApp 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}
-Constructors
-~~~~~~~~~~~~
+
+%************************************************************************
+%* *
+ 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}
-tcConDecl :: TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM s Id
-
-tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (VanillaCon btys) src_loc)
- = tcDataCon tycon tyvars ctxt name btys src_loc
-
-tcConDecl tycon tyvars ctxt (ConDecl op ex_ctxt (InfixCon bty1 bty2) src_loc)
- = tcDataCon tycon tyvars ctxt op [bty1,bty2] src_loc
-
-tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (NewCon ty) src_loc)
- = tcAddSrcLoc src_loc $
- tcHsType 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.
- checkTc (not (isUnboxedType arg_ty)) (newTypeUnboxedField ty) `thenTc_`
- let
- data_con = mkDataCon (getName name)
- [NotMarkedStrict]
- [{- No labelled fields -}]
- tyvars
- ctxt
- [] [] -- Temporary; existential chaps
- [arg_ty]
- tycon
- in
- returnTc data_con
-
-tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (RecCon fields) src_loc)
- = tcAddSrcLoc src_loc $
- mapTc tcField fields `thenTc` \ field_label_infos_s ->
- let
- field_label_infos = concat field_label_infos_s
- stricts = [strict | (_, _, strict) <- field_label_infos]
- arg_tys = [ty | (_, ty, _) <- field_label_infos]
-
- field_labels = [ mkFieldLabel (getName name) ty tag
- | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ]
-
- data_con = mkDataCon (getName name)
- stricts
- field_labels
- tyvars
- (thinContext arg_tys ctxt)
- [] [] -- Temporary; existential chaps
- arg_tys
- tycon
- in
- returnTc data_con
-
-tcField (field_label_names, bty)
- = tcHsType (get_pty bty) `thenTc` \ field_ty ->
- returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
-
-tcDataCon tycon tyvars ctxt name btys src_loc
- = tcAddSrcLoc src_loc $
- let
- stricts = map get_strictness btys
- tys = map get_pty btys
- in
- mapTc tcHsType tys `thenTc` \ arg_tys ->
- let
- data_con = mkDataCon (getName name)
- stricts
- [{- No field labels -}]
- tyvars
- (thinContext arg_tys ctxt)
- [] [] -- Temporary existential chaps
- arg_tys
- tycon
- in
- returnTc 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
+calcTyConArgVrcs :: [TyThing] -> Name -> ArgVrcs
+-- Gives arg variances for TyCons,
+-- including the class TyCon of a class
+calcTyConArgVrcs tyclss
+ = get_vrc
where
- arg_tyvars = tyVarsOfTypes arg_tys
- in_arg_tys (clas,tys) = not $ isEmptyTyVarSet $
- tyVarsOfTypes tys `intersectTyVarSets` arg_tyvars
-
-get_strictness (Banged _) = MarkedStrict
-get_strictness (Unbanged _) = NotMarkedStrict
-
-get_pty (Banged ty) = ty
-get_pty (Unbanged ty) = ty
+ 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 dataConOrigArgTys 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.
-Errors and contexts
-~~~~~~~~~~~~~~~~~~~
\begin{code}
-tySynCtxt tycon_name
- = hsep [ptext SLIT("In the type declaration for"), quotes (ppr tycon_name)]
+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 (PredTy st) = vrcInTy fao v (predTypeRep st)
+\end{code}
+
+Variance algebra
+~~~~~~~~~~~~~~~~
-tyDataCtxt tycon_name
- = hsep [ptext SLIT("In the data declaration for"), quotes (ppr tycon_name)]
+\begin{code}
+orVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
+orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2)
-tyNewCtxt tycon_name
- = hsep [ptext SLIT("In the newtype declaration for"), quotes (ppr tycon_name)]
+orVrcs :: [(Bool,Bool)] -> (Bool,Bool)
+orVrcs = foldl orVrc (False,False)
-fieldTypeMisMatch field_name
- = sep [ptext SLIT("Declared types differ for field"), quotes (ppr field_name)]
+negVrc :: (Bool,Bool) -> (Bool,Bool)
+negVrc (p1,m1) = (m1,p1)
-newTypeUnboxedField ty
- = sep [ptext SLIT("Newtype constructor field has an unboxed type:"),
- quotes (ppr ty)]
+anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool)
+anyVrc p as = foldl (\ pm a -> pm `orVrc` p a)
+ (False,False) as
-evalCtxt con eval_theta
- = hsep [ptext SLIT("When checking the Eval context for constructor:"),
- ppr con,
- text "::", ppr eval_theta]
+timesVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)
+timesVrc (p1,m1) (p2,m2) = (p1 && p2 || m1 && m2,
+ p1 && m2 || m1 && p2)
\end{code}