Commit 31398fbc authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Test for type synonym loops on TyCon.



Summary:
Previously, we tested for type synonym loops by doing
a syntactic test on the literal type synonym declarations.
However, in some cases, loops could go through hs-boot
files, leading to an infinite loop (#12042); a similar
situation can occur when signature merging.

This commit replaces the syntactic test with a test on
TyCon, simply by walking down all type synonyms until
we bottom out, or find we've looped back.  It's a lot
simpler.
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: simonpj, austin, bgamari

Subscribers: goldfire, thomie

Differential Revision: https://phabricator.haskell.org/D2656

GHC Trac Issues: #12042
parent b7695867
...@@ -619,6 +619,7 @@ countTyClDecls decls ...@@ -619,6 +619,7 @@ countTyClDecls decls
hsDeclHasCusk :: TyClDecl Name -> Bool hsDeclHasCusk :: TyClDecl Name -> Bool
hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk Nothing fam_decl hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk Nothing fam_decl
hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
-- NB: Keep this synchronized with 'getInitialKind'
= hsTvbAllKinded tyvars && rhs_annotated rhs = hsTvbAllKinded tyvars && rhs_annotated rhs
where where
rhs_annotated (L _ ty) = case ty of rhs_annotated (L _ ty) = case ty of
......
...@@ -21,6 +21,7 @@ import DynFlags ...@@ -21,6 +21,7 @@ import DynFlags
import HsSyn import HsSyn
import RdrName import RdrName
import TcRnMonad import TcRnMonad
import TcTyDecls
import InstEnv import InstEnv
import FamInstEnv import FamInstEnv
import Inst import Inst
...@@ -395,6 +396,9 @@ mergeSignatures lcl_iface0 = do ...@@ -395,6 +396,9 @@ mergeSignatures lcl_iface0 = do
typecheckIfacesForMerging inner_mod ifaces type_env_var typecheckIfacesForMerging inner_mod ifaces type_env_var
let infos = zip ifaces detailss let infos = zip ifaces detailss
-- Test for cycles
checkSynCycles (thisPackage dflags) (typeEnvTyCons type_env) []
-- NB on type_env: it contains NO dfuns. DFuns are recorded inside -- NB on type_env: it contains NO dfuns. DFuns are recorded inside
-- detailss, and given a Name that doesn't correspond to anything real. See -- detailss, and given a Name that doesn't correspond to anything real. See
-- also Note [Signature merging DFuns] -- also Note [Signature merging DFuns]
......
...@@ -1134,7 +1134,9 @@ tcMonoBinds is_rec sig_fn no_gen ...@@ -1134,7 +1134,9 @@ tcMonoBinds is_rec sig_fn no_gen
-- Single function binding, -- Single function binding,
| NonRecursive <- is_rec -- ...binder isn't mentioned in RHS | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
, Nothing <- sig_fn name -- ...with no type signature , Nothing <- sig_fn name -- ...with no type signature
= -- In this very special case we infer the type of the = -- Note [Single function non-recursive binding special-case]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- In this very special case we infer the type of the
-- right hand side first (it may have a higher-rank type) -- right hand side first (it may have a higher-rank type)
-- and *then* make the monomorphic Id for the LHS -- and *then* make the monomorphic Id for the LHS
-- e.g. f = \(x::forall a. a->a) -> <body> -- e.g. f = \(x::forall a. a->a) -> <body>
......
...@@ -63,7 +63,6 @@ import Unify ...@@ -63,7 +63,6 @@ import Unify
import Util import Util
import SrcLoc import SrcLoc
import ListSetOps import ListSetOps
import Digraph
import DynFlags import DynFlags
import Unique import Unique
import BasicTypes import BasicTypes
...@@ -150,6 +149,12 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds ...@@ -150,6 +149,12 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
-- Step 1: Typecheck the type/class declarations -- Step 1: Typecheck the type/class declarations
; tyclss <- tcTyClDecls tyclds role_annots ; tyclss <- tcTyClDecls tyclds role_annots
-- Step 1.5: Make sure we don't have any type synonym cycles
; traceTc "Starting synonym cycle check" (ppr tyclss)
; this_uid <- fmap thisPackage getDynFlags
; checkSynCycles this_uid tyclss tyclds
; traceTc "Done synonym cycle check" (ppr tyclss)
-- Step 2: Perform the validity check on those types/classes -- Step 2: Perform the validity check on those types/classes
-- We can do this now because we are done with the recursive knot -- We can do this now because we are done with the recursive knot
-- Do it before Step 3 (adding implicit things) because the latter -- Do it before Step 3 (adding implicit things) because the latter
...@@ -172,7 +177,6 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds ...@@ -172,7 +177,6 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
; return (gbl_env, inst_info, datafam_deriv_info) } } } ; return (gbl_env, inst_info, datafam_deriv_info) } } }
tcTyClDecls :: [LTyClDecl Name] -> RoleAnnotEnv -> TcM [TyCon] tcTyClDecls :: [LTyClDecl Name] -> RoleAnnotEnv -> TcM [TyCon]
tcTyClDecls tyclds role_annots tcTyClDecls tyclds role_annots
= do { -- Step 1: kind-check this group and returns the final = do { -- Step 1: kind-check this group and returns the final
...@@ -183,6 +187,10 @@ tcTyClDecls tyclds role_annots ...@@ -183,6 +187,10 @@ tcTyClDecls tyclds role_annots
-- Step 2: type-check all groups together, returning -- Step 2: type-check all groups together, returning
-- the final TyCons and Classes -- the final TyCons and Classes
--
-- NB: We have to be careful here to NOT eagerly unfold
-- type synonyms, as we have not tested for type synonym
-- loops yet and could fall into a black hole.
; fixM $ \ ~rec_tyclss -> do ; fixM $ \ ~rec_tyclss -> do
{ is_boot <- tcIsHsBootOrSig { is_boot <- tcIsHsBootOrSig
; let roles = inferRoles is_boot role_annots rec_tyclss ; let roles = inferRoles is_boot role_annots rec_tyclss
...@@ -241,14 +249,10 @@ Note [Kind checking for type and class decls] ...@@ -241,14 +249,10 @@ Note [Kind checking for type and class decls]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Kind checking is done thus: Kind checking is done thus:
1. Make up a kind variable for each parameter of the *data* type, class, 1. Make up a kind variable for each parameter of the declarations,
and closed type family decls, and extend the kind environment (which is and extend the kind environment (which is in the TcLclEnv)
in the TcLclEnv)
2. Dependency-analyse the type *synonyms* (which must be non-recursive), 2. Kind check the declarations
and kind-check them in dependency order. Extend the kind envt.
3. Kind check the data type and class decls
We need to kind check all types in the mutually recursive group We need to kind check all types in the mutually recursive group
before we know the kind of the type variables. For example: before we know the kind of the type variables. For example:
...@@ -263,21 +267,18 @@ Here, the kind of the locally-polymorphic type variable "b" ...@@ -263,21 +267,18 @@ Here, the kind of the locally-polymorphic type variable "b"
depends on *all the uses of class D*. For example, the use of depends on *all the uses of class D*. For example, the use of
Monad c in bop's type signature means that D must have kind Type->Type. Monad c in bop's type signature means that D must have kind Type->Type.
However type synonyms work differently. They can have kinds which don't Note: we don't treat type synonyms specially (we used to, in the past);
just involve (->) and *: in particular, even if we have a type synonym cycle, we still kind check
type R = Int# -- Kind # it normally, and test for cycles later (checkSynCycles). The reason
type S a = Array# a -- Kind * -> # we can get away with this is because we have more systematic TYPE r
type T a b = (# a,b #) -- Kind * -> * -> (# a,b #) inference, which means that we can do unification between kinds that
and a kind variable can't unify with UnboxedTypeKind. aren't lifted (this historically was not true.)
So we must infer the kinds of type synonyms from their right-hand
sides *first* and then use them, whereas for the mutually recursive
data types D we bring into scope kind bindings D -> k, where k is a
kind variable, and do inference.
NB: synonyms can be mutually recursive with data type declarations though! The downside of not directly reading off the kinds off the RHS of
type T = D -> D type synonyms in topological order is that we don't transparently
data D = MkD Int T support making synonyms of types with higher-rank kinds. But
you can always specify a CUSK directly to make this work out.
See tc269 for an example.
Open type families Open type families
~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~
...@@ -296,7 +297,28 @@ See also Note [Kind checking recursive type and class declarations] ...@@ -296,7 +297,28 @@ See also Note [Kind checking recursive type and class declarations]
-} -}
-- Note [Missed opportunity to retain higher-rank kinds]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- In 'kcTyClGroup', there is a missed opportunity to make kind
-- inference work in a few more cases. The idea is analogous
-- to Note [Single function non-recursive binding special-case]:
--
-- * If we have an SCC with a single decl, which is non-recursive,
-- instead of creating a unification variable representing the
-- kind of the decl and unifying it with the rhs, we can just
-- read the type directly of the rhs.
--
-- * Furthermore, we can update our SCC analysis to ignore
-- dependencies on declarations which have CUSKs: we don't
-- have to kind-check these all at once, since we can use
-- the CUSK to initialize the kind environment.
--
-- Unfortunately this requires reworking a bit of the code in
-- 'kcLTyClDecl' so I've decided to punt unless someone shouts about it.
--
kcTyClGroup :: [LTyClDecl Name] -> TcM [TcTyCon] kcTyClGroup :: [LTyClDecl Name] -> TcM [TcTyCon]
-- Kind check this group, kind generalize, and return the resulting local env -- Kind check this group, kind generalize, and return the resulting local env
-- This bindds the TyCons and Classes of the group, but not the DataCons -- This bindds the TyCons and Classes of the group, but not the DataCons
-- See Note [Kind checking for type and class decls] -- See Note [Kind checking for type and class decls]
...@@ -307,29 +329,23 @@ kcTyClGroup decls ...@@ -307,29 +329,23 @@ kcTyClGroup decls
; traceTc "kcTyClGroup" (text "module" <+> ppr mod $$ vcat (map ppr decls)) ; traceTc "kcTyClGroup" (text "module" <+> ppr mod $$ vcat (map ppr decls))
-- Kind checking; -- Kind checking;
-- 1. Bind kind variables for non-synonyms -- 1. Bind kind variables for decls
-- 2. Kind-check synonyms, and bind kinds of those synonyms -- 2. Kind-check decls
-- 3. Kind-check non-synonyms -- 3. Generalise the inferred kinds
-- 4. Generalise the inferred kinds
-- See Note [Kind checking for type and class decls] -- See Note [Kind checking for type and class decls]
; lcl_env <- solveEqualities $ ; lcl_env <- solveEqualities $
do { do {
-- Step 1: Bind kind variables for non-synonyms -- Step 1: Bind kind variables for all decls
let (syn_decls, non_syn_decls) = partition (isSynDecl . unLoc) decls initial_kinds <- getInitialKinds decls
; initial_kinds <- getInitialKinds non_syn_decls
; traceTc "kcTyClGroup: initial kinds" $ ; traceTc "kcTyClGroup: initial kinds" $
vcat (map pp_initial_kind initial_kinds) vcat (map pp_initial_kind initial_kinds)
; tcExtendKindEnv2 initial_kinds $ do {
-- Step 2: Set initial envt, kind-check the synonyms -- Step 2: Set extended envt, kind-check the decls
; lcl_env <- tcExtendKindEnv2 initial_kinds $ ; mapM_ kcLTyClDecl decls
kcSynDecls (calcSynCycles syn_decls)
-- Step 3: Set extended envt, kind-check the non-synonyms
; setLclEnv lcl_env $
mapM_ kcLTyClDecl non_syn_decls
; return lcl_env } ; getLclEnv } }
-- Step 4: generalisation -- Step 4: generalisation
-- Kind checking done for this group -- Kind checking done for this group
...@@ -462,8 +478,22 @@ getInitialKind decl@(DataDecl { tcdLName = L _ name ...@@ -462,8 +478,22 @@ getInitialKind decl@(DataDecl { tcdLName = L _ name
getInitialKind (FamDecl { tcdFam = decl }) getInitialKind (FamDecl { tcdFam = decl })
= getFamDeclInitialKind Nothing decl = getFamDeclInitialKind Nothing decl
getInitialKind decl@(SynDecl {}) getInitialKind decl@(SynDecl { tcdLName = L _ name
= pprPanic "getInitialKind" (ppr decl) , tcdTyVars = ktvs
, tcdRhs = rhs })
= do { (tycon, _) <- kcHsTyVarBndrs name False (hsDeclHasCusk decl)
False {- not open -} True ktvs $
do { res_k <- case kind_annotation rhs of
Nothing -> newMetaKindVar
Just ksig -> tcLHsKind ksig
; return (res_k, ()) }
; return [ mkTcTyConPair tycon ] }
where
-- Keep this synchronized with 'hsDeclHasCusk'.
kind_annotation (L _ ty) = case ty of
HsParTy lty -> kind_annotation lty
HsKindSig _ k -> Just k
_ -> Nothing
--------------------------------- ---------------------------------
getFamDeclInitialKinds :: Maybe Bool -- if assoc., CUSKness of assoc. class getFamDeclInitialKinds :: Maybe Bool -- if assoc., CUSKness of assoc. class
...@@ -499,37 +529,6 @@ getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName = L _ name ...@@ -499,37 +529,6 @@ getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName = L _ name
OpenTypeFamily -> (True, False) OpenTypeFamily -> (True, False)
ClosedTypeFamily _ -> (False, False) ClosedTypeFamily _ -> (False, False)
----------------
kcSynDecls :: [SCC (LTyClDecl Name)]
-> TcM TcLclEnv -- Kind bindings
kcSynDecls [] = getLclEnv
kcSynDecls (group : groups)
= do { tc <- kcSynDecl1 group
; traceTc "kcSynDecl" (ppr tc <+> dcolon <+> ppr (tyConKind tc))
; tcExtendKindEnv2 [ mkTcTyConPair tc ] $
kcSynDecls groups }
kcSynDecl1 :: SCC (LTyClDecl Name)
-> TcM TcTyCon -- Kind bindings
kcSynDecl1 (AcyclicSCC (L _ decl)) = kcSynDecl decl
kcSynDecl1 (CyclicSCC decls) = do { recSynErr decls; failM }
-- Fail here to avoid error cascade
-- of out-of-scope tycons
kcSynDecl :: TyClDecl Name -> TcM TcTyCon
kcSynDecl decl@(SynDecl { tcdTyVars = hs_tvs, tcdLName = L _ name
, tcdRhs = rhs })
-- Returns a possibly-unzonked kind
= tcAddDeclCtxt decl $
do { (tycon, _) <-
kcHsTyVarBndrs name False (hsDeclHasCusk decl) False True hs_tvs $
do { traceTc "kcd1" (ppr name <+> brackets (ppr hs_tvs))
; (_, rhs_kind) <- tcLHsType rhs
; traceTc "kcd2" (ppr name)
; return (rhs_kind, ()) }
; return tycon }
kcSynDecl decl = pprPanic "kcSynDecl" (ppr decl)
------------------------------------------------------------------------ ------------------------------------------------------------------------
kcLTyClDecl :: LTyClDecl Name -> TcM () kcLTyClDecl :: LTyClDecl Name -> TcM ()
-- See Note [Kind checking for type and class decls] -- See Note [Kind checking for type and class decls]
...@@ -557,7 +556,12 @@ kcTyClDecl (DataDecl { tcdLName = L _ name, tcdDataDefn = defn }) ...@@ -557,7 +556,12 @@ kcTyClDecl (DataDecl { tcdLName = L _ name, tcdDataDefn = defn })
do { _ <- tcHsContext ctxt do { _ <- tcHsContext ctxt
; mapM_ (wrapLocM kcConDecl) cons } ; mapM_ (wrapLocM kcConDecl) cons }
kcTyClDecl decl@(SynDecl {}) = pprPanic "kcTyClDecl" (ppr decl) kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = lrhs })
= kcTyClTyVars name $
do { syn_tc <- kcLookupTcTyCon name
-- NB: check against the result kind that we allocated
-- in getInitialKinds.
; discardResult $ tcCheckLHsType lrhs (tyConResKind syn_tc) }
kcTyClDecl (ClassDecl { tcdLName = L _ name kcTyClDecl (ClassDecl { tcdLName = L _ name
, tcdCtxt = ctxt, tcdSigs = sigs }) , tcdCtxt = ctxt, tcdSigs = sigs })
...@@ -2742,15 +2746,6 @@ noClassTyVarErr clas fam_tc ...@@ -2742,15 +2746,6 @@ noClassTyVarErr clas fam_tc
, text "mentions none of the type or kind variables of the class" <+> , text "mentions none of the type or kind variables of the class" <+>
quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))] quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))]
recSynErr :: [LTyClDecl Name] -> TcRn ()
recSynErr syn_decls
= setSrcSpan (getLoc (head sorted_decls)) $
addErr (sep [text "Cycle in type synonym declarations:",
nest 2 (vcat (map ppr_decl sorted_decls))])
where
sorted_decls = sortLocated syn_decls
ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl
badDataConTyCon :: DataCon -> Type -> Type -> SDoc badDataConTyCon :: DataCon -> Type -> Type -> SDoc
badDataConTyCon data_con res_ty_tmpl actual_res_ty badDataConTyCon data_con res_ty_tmpl actual_res_ty
= hang (text "Data constructor" <+> quotes (ppr data_con) <+> = hang (text "Data constructor" <+> quotes (ppr data_con) <+>
......
...@@ -14,7 +14,7 @@ files for imported data types. ...@@ -14,7 +14,7 @@ files for imported data types.
module TcTyDecls( module TcTyDecls(
RolesInfo, RolesInfo,
inferRoles, inferRoles,
calcSynCycles, checkSynCycles,
checkClassCycles, checkClassCycles,
-- * Implicits -- * Implicits
...@@ -30,7 +30,7 @@ import TcRnMonad ...@@ -30,7 +30,7 @@ import TcRnMonad
import TcEnv import TcEnv
import TcBinds( tcRecSelBinds ) import TcBinds( tcRecSelBinds )
import RnEnv( RoleAnnotEnv, lookupRoleAnnot ) import RnEnv( RoleAnnotEnv, lookupRoleAnnot )
import TyCoRep( Type(..) ) import TyCoRep( Type(..), Coercion(..), UnivCoProvenance(..) )
import TcType import TcType
import TysWiredIn( unitTy ) import TysWiredIn( unitTy )
import MkCore( rEC_SEL_ERROR_ID ) import MkCore( rEC_SEL_ERROR_ID )
...@@ -50,7 +50,6 @@ import VarEnv ...@@ -50,7 +50,6 @@ import VarEnv
import VarSet import VarSet
import NameSet ( NameSet, unitNameSet, extendNameSet, elemNameSet ) import NameSet ( NameSet, unitNameSet, extendNameSet, elemNameSet )
import Coercion ( ltRole ) import Coercion ( ltRole )
import Digraph
import BasicTypes import BasicTypes
import SrcLoc import SrcLoc
import Unique ( mkBuiltinUnique ) import Unique ( mkBuiltinUnique )
...@@ -60,7 +59,7 @@ import Maybes ...@@ -60,7 +59,7 @@ import Maybes
import Bag import Bag
import FastString import FastString
import FV import FV
import UniqFM import Module
import Control.Monad import Control.Monad
...@@ -70,77 +69,163 @@ import Control.Monad ...@@ -70,77 +69,163 @@ import Control.Monad
Cycles in type synonym declarations Cycles in 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 already have the free vars pinned on the decl
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
synonymTyConsOfType :: Type -> [TyCon] synonymTyConsOfType :: Type -> [TyCon]
-- Does not look through type synonyms at all -- Does not look through type synonyms at all
-- Return a list of synonym tycons -- Return a list of synonym tycons
-- Keep this synchronized with 'expandTypeSynonyms'
synonymTyConsOfType ty synonymTyConsOfType ty
= nameEnvElts (go ty) = nameEnvElts (go ty)
where where
go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
go (TyVarTy v) = emptyNameEnv go (TyConApp tc tys) = go_tc tc `plusNameEnv` go_s tys
go (TyConApp tc tys) = go_tc tc tys go (LitTy _) = emptyNameEnv
go (TyVarTy _) = emptyNameEnv
go (AppTy a b) = go a `plusNameEnv` go b go (AppTy a b) = go a `plusNameEnv` go b
go (FunTy a b) = go a `plusNameEnv` go b go (FunTy a b) = go a `plusNameEnv` go b
go (ForAllTy _ ty) = go ty go (ForAllTy _ ty) = go ty
go (CastTy ty co) = go ty `plusNameEnv` go_co co
go_tc tc tys | isTypeSynonymTyCon tc = extendNameEnv (go_s tys) go (CoercionTy co) = go_co co
(tyConName tc) tc
| otherwise = go_s tys -- Note [TyCon cycles through coercions?!]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Although, in principle, it's possible for a type synonym loop
-- could go through a coercion (since a coercion can refer to
-- a TyCon or Type), it doesn't seem possible to actually construct
-- a Haskell program which tickles this case. Here is an example
-- program which causes a coercion:
--
-- type family Star where
-- Star = Type
--
-- data T :: Star -> Type
-- data S :: forall (a :: Type). T a -> Type
--
-- Here, the application 'T a' must first coerce a :: Type to a :: Star,
-- witnessed by the type family. But if we now try to make Type refer
-- to a type synonym which in turn refers to Star, we'll run into
-- trouble: we're trying to define and use the type constructor
-- in the same recursive group. Possibly this restriction will be
-- lifted in the future but for now, this code is "just for completeness
-- sake".
go_co (Refl _ ty) = go ty
go_co (TyConAppCo _ tc cs) = go_tc tc `plusNameEnv` go_co_s cs
go_co (AppCo co co') = go_co co `plusNameEnv` go_co co'
go_co (ForAllCo _ co co') = go_co co `plusNameEnv` go_co co'
go_co (CoVarCo _) = emptyNameEnv
go_co (AxiomInstCo _ _ cs) = go_co_s cs
go_co (UnivCo p _ ty ty') = go_prov p `plusNameEnv` go ty `plusNameEnv` go ty'
go_co (SymCo co) = go_co co
go_co (TransCo co co') = go_co co `plusNameEnv` go_co co'
go_co (NthCo _ co) = go_co co
go_co (LRCo _ co) = go_co co
go_co (InstCo co co') = go_co co `plusNameEnv` go_co co'
go_co (CoherenceCo co co') = go_co co `plusNameEnv` go_co co'
go_co (KindCo co) = go_co co
go_co (SubCo co) = go_co co
go_co (AxiomRuleCo _ cs) = go_co_s cs
go_prov UnsafeCoerceProv = emptyNameEnv
go_prov (PhantomProv co) = go_co co
go_prov (ProofIrrelProv co) = go_co co
go_prov (PluginProv _) = emptyNameEnv
go_prov (HoleProv _) = emptyNameEnv
go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc
| otherwise = emptyNameEnv
go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
---------------------------------------- END NOTE ] go_co_s cos = foldr (plusNameEnv . go_co) emptyNameEnv cos
-}
-- | A monad for type synonym cycle checking, which keeps
-- track of the TyCons which are known to be acyclic, or
-- a failure message reporting that a cycle was found.
newtype SynCycleM a = SynCycleM {
runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) }
type SynCycleState = NameSet
instance Functor SynCycleM where
fmap = liftM
instance Applicative SynCycleM where
pure x = SynCycleM $ \state -> Right (x, state)
(<*>) = ap
instance Monad SynCycleM where
m >>= f = SynCycleM $ \state ->
case runSynCycleM m state of
Right (x, state') ->
runSynCycleM (f x) state'
Left err -> Left err
failSynCycleM :: SrcSpan -> SDoc -> SynCycleM ()
failSynCycleM loc err = SynCycleM $ \_ -> Left (loc, err)
-- | Test if a 'Name' is acyclic, short-circuiting if we've
-- seen it already.
checkNameIsAcyclic :: Name -> SynCycleM () -> SynCycleM ()
checkNameIsAcyclic n m = SynCycleM $ \s ->
if n `elemNameSet` s
then Right ((), s) -- short circuit
else case runSynCycleM m s of
Right ((), s') -> Right ((), extendNameSet s' n)
Left err -> Left err
-- | Checks if any of the passed in 'TyCon's have cycles.
-- Takes the 'UnitId' of the home package (as we can avoid
-- checking those TyCons: cycles never go through foreign packages) and
-- the corresponding @LTyClDecl Name@ for each 'TyCon', so we
-- can give better error messages.
checkSynCycles :: UnitId -> [TyCon] -> [LTyClDecl Name] -> TcM ()
checkSynCycles this_uid tcs tyclds = do
case runSynCycleM (mapM_ (go emptyNameEnv []) tcs) emptyNameEnv of
Left (loc, err) -> setSrcSpan loc $ failWithTc err
Right _ -> return ()
where
-- Try our best to print the LTyClDecl for locally defined things
lcl_decls = mkNameEnv (zip (map tyConName tcs) tyclds)
-- Short circuit if we've already seen this Name and concluded
-- it was acyclic.
go :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()
go so_far seen_tcs tc =
checkNameIsAcyclic (tyConName tc) $ go' so_far seen_tcs tc
-- Expand type synonyms, complaining if you find the same
-- type synonym a second time.