Commit ef950b19 authored by Andreas Klebinger's avatar Andreas Klebinger Committed by Marge Bot

Add TyCon Set/Env and use them in a few places.

Firstly this improves code clarity.

But it also has performance benefits as we no longer
go through the name of the TyCon to get at it's unique.

In order to make this work the recursion check for TyCon
has been moved into it's own module in order to avoid import
cycles.
parent e5c7c9c8
Pipeline #26023 failed
......@@ -135,6 +135,7 @@ import GHC.Core.TyCo.Subst
import GHC.Core.TyCo.Tidy
import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Core.TyCon.RecWalk
import GHC.Core.Coercion.Axiom
import {-# SOURCE #-} GHC.Core.Utils ( mkFunctionType )
import GHC.Types.Var
......
......@@ -52,7 +52,8 @@ import GHC.Core.Type as Type
import GHC.Core.Coercion as Type
import GHC.Core.DataCon
import GHC.Core.TyCon ( initRecTc, checkRecTc, tyConArity )
import GHC.Core.TyCon ( tyConArity )
import GHC.Core.TyCon.RecWalk ( initRecTc, checkRecTc )
import GHC.Core.Predicate ( isDictTy )
import GHC.Core.Multiplicity
import GHC.Types.Var.Set
......
......@@ -31,7 +31,7 @@ import GHC.Core.DataCon
import GHC.Core.Coercion hiding( substCo )
import GHC.Core.Rules
import GHC.Core.Type hiding ( substTy )
import GHC.Core.TyCon ( tyConName )
import GHC.Core.TyCon ( tyConUnique )
import GHC.Core.Multiplicity
import GHC.Types.Id
import GHC.Core.Ppr ( pprParendExpr )
......@@ -56,7 +56,7 @@ import GHC.Types.Unique.FM
import GHC.Utils.Monad
import Control.Monad ( zipWithM )
import Data.List
import GHC.Builtin.Names ( specTyConName )
import GHC.Builtin.Names ( specTyConKey )
import GHC.Unit.Module
import Data.Ord( comparing )
......@@ -983,7 +983,7 @@ forceSpecArgTy env ty
forceSpecArgTy env ty
| Just (tycon, tys) <- splitTyConApp_maybe ty
, tycon /= funTyCon
= tyConName tycon == specTyConName
= tyConUnique tycon == specTyConKey
|| any (forceSpecArgTy env) tys
forceSpecArgTy _ _ = False
......
......@@ -40,6 +40,7 @@ import GHC.Core.Coercion
import GHC.Core.FamInstEnv
import GHC.Types.Basic ( Boxity(..) )
import GHC.Core.TyCon
import GHC.Core.TyCon.RecWalk
import GHC.Types.Unique.Supply
import GHC.Types.Unique
import GHC.Data.Maybe
......
......@@ -34,6 +34,7 @@ import GHC.Prelude
import GHC.Core.Type
import GHC.Core.Class
import GHC.Core.TyCon
import GHC.Core.TyCon.RecWalk
import GHC.Types.Var
import GHC.Core.Coercion
import GHC.Core.Multiplicity ( scaledThing )
......
......@@ -126,10 +126,6 @@ module GHC.Core.TyCon(
primRepsCompatible,
primRepCompatible,
-- * Recursion breaking
RecTcChecker, initRecTc, defaultRecTcMaxBound,
setRecTcMaxBound, checkRecTc
) where
#include "HsVersions.h"
......@@ -2710,83 +2706,6 @@ instance Binary Injectivity where
_ -> do { xs <- get bh
; return (Injective xs) } }
{-
************************************************************************
* *
Walking over recursive TyCons
* *
************************************************************************
Note [Expanding newtypes and products]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When expanding a type to expose a data-type constructor, we need to be
careful about newtypes, lest we fall into an infinite loop. Here are
the key examples:
newtype Id x = MkId x
newtype Fix f = MkFix (f (Fix f))
newtype T = MkT (T -> T)
Type Expansion
--------------------------
T T -> T
Fix Maybe Maybe (Fix Maybe)
Id (Id Int) Int
Fix Id NO NO NO
Notice that
* We can expand T, even though it's recursive.
* We can expand Id (Id Int), even though the Id shows up
twice at the outer level, because Id is non-recursive
So, when expanding, we keep track of when we've seen a recursive
newtype at outermost level; and bail out if we see it again.
We sometimes want to do the same for product types, so that the
strictness analyser doesn't unbox infinitely deeply.
More precisely, we keep a *count* of how many times we've seen it.
This is to account for
data instance T (a,b) = MkT (T a) (T b)
Then (#10482) if we have a type like
T (Int,(Int,(Int,(Int,Int))))
we can still unbox deeply enough during strictness analysis.
We have to treat T as potentially recursive, but it's still
good to be able to unwrap multiple layers.
The function that manages all this is checkRecTc.
-}
data RecTcChecker = RC !Int (NameEnv Int)
-- The upper bound, and the number of times
-- we have encountered each TyCon
-- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'.
initRecTc :: RecTcChecker
initRecTc = RC defaultRecTcMaxBound emptyNameEnv
-- | The default upper bound (100) for the number of times a 'RecTcChecker' is
-- allowed to encounter each 'TyCon'.
defaultRecTcMaxBound :: Int
defaultRecTcMaxBound = 100
-- Should we have a flag for this?
-- | Change the upper bound for the number of times a 'RecTcChecker' is allowed
-- to encounter each 'TyCon'.
setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker
setRecTcMaxBound new_bound (RC _old_bound rec_nts) = RC new_bound rec_nts
checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker
-- Nothing => Recursion detected
-- Just rec_tcs => Keep going
checkRecTc (RC bound rec_nts) tc
= case lookupNameEnv rec_nts tc_name of
Just n | n >= bound -> Nothing
| otherwise -> Just (RC bound (extendNameEnv rec_nts tc_name (n+1)))
Nothing -> Just (RC bound (extendNameEnv rec_nts tc_name 1))
where
tc_name = tyConName tc
-- | Returns whether or not this 'TyCon' is definite, or a hole
-- that may be filled in at some later point. See Note [Skolem abstract data]
tyConSkolem :: TyCon -> Bool
......
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
\section[TyConEnv]{@TyConEnv@: tyCon environments}
-}
{-# LANGUAGE CPP, DeriveDataTypeable #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module GHC.Core.TyCon.Env (
-- * TyCon environment (map)
TyConEnv,
-- ** Manipulating these environments
mkTyConEnv, mkTyConEnvWith,
emptyTyConEnv, isEmptyTyConEnv,
unitTyConEnv, nameEnvElts,
extendTyConEnv_C, extendTyConEnv_Acc, extendTyConEnv,
extendTyConEnvList, extendTyConEnvList_C,
filterTyConEnv, anyTyConEnv,
plusTyConEnv, plusTyConEnv_C, plusTyConEnv_CD, plusTyConEnv_CD2, alterTyConEnv,
lookupTyConEnv, lookupTyConEnv_NF, delFromTyConEnv, delListFromTyConEnv,
elemTyConEnv, mapTyConEnv, disjointTyConEnv,
DTyConEnv,
emptyDTyConEnv,
lookupDTyConEnv,
delFromDTyConEnv, filterDTyConEnv,
mapDTyConEnv,
adjustDTyConEnv, alterDTyConEnv, extendDTyConEnv,
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Types.Unique.FM
import GHC.Types.Unique.DFM
import GHC.Core.TyCon (TyCon)
import GHC.Data.Maybe
{-
************************************************************************
* *
\subsection{TyCon environment}
* *
************************************************************************
-}
-- | TyCon Environment
type TyConEnv a = UniqFM TyCon a -- Domain is TyCon
emptyTyConEnv :: TyConEnv a
isEmptyTyConEnv :: TyConEnv a -> Bool
mkTyConEnv :: [(TyCon,a)] -> TyConEnv a
mkTyConEnvWith :: (a -> TyCon) -> [a] -> TyConEnv a
nameEnvElts :: TyConEnv a -> [a]
alterTyConEnv :: (Maybe a-> Maybe a) -> TyConEnv a -> TyCon -> TyConEnv a
extendTyConEnv_C :: (a->a->a) -> TyConEnv a -> TyCon -> a -> TyConEnv a
extendTyConEnv_Acc :: (a->b->b) -> (a->b) -> TyConEnv b -> TyCon -> a -> TyConEnv b
extendTyConEnv :: TyConEnv a -> TyCon -> a -> TyConEnv a
plusTyConEnv :: TyConEnv a -> TyConEnv a -> TyConEnv a
plusTyConEnv_C :: (a->a->a) -> TyConEnv a -> TyConEnv a -> TyConEnv a
plusTyConEnv_CD :: (a->a->a) -> TyConEnv a -> a -> TyConEnv a -> a -> TyConEnv a
plusTyConEnv_CD2 :: (Maybe a->Maybe a->a) -> TyConEnv a -> TyConEnv a -> TyConEnv a
extendTyConEnvList :: TyConEnv a -> [(TyCon,a)] -> TyConEnv a
extendTyConEnvList_C :: (a->a->a) -> TyConEnv a -> [(TyCon,a)] -> TyConEnv a
delFromTyConEnv :: TyConEnv a -> TyCon -> TyConEnv a
delListFromTyConEnv :: TyConEnv a -> [TyCon] -> TyConEnv a
elemTyConEnv :: TyCon -> TyConEnv a -> Bool
unitTyConEnv :: TyCon -> a -> TyConEnv a
lookupTyConEnv :: TyConEnv a -> TyCon -> Maybe a
lookupTyConEnv_NF :: TyConEnv a -> TyCon -> a
filterTyConEnv :: (elt -> Bool) -> TyConEnv elt -> TyConEnv elt
anyTyConEnv :: (elt -> Bool) -> TyConEnv elt -> Bool
mapTyConEnv :: (elt1 -> elt2) -> TyConEnv elt1 -> TyConEnv elt2
disjointTyConEnv :: TyConEnv a -> TyConEnv a -> Bool
nameEnvElts x = eltsUFM x
emptyTyConEnv = emptyUFM
isEmptyTyConEnv = isNullUFM
unitTyConEnv x y = unitUFM x y
extendTyConEnv x y z = addToUFM x y z
extendTyConEnvList x l = addListToUFM x l
lookupTyConEnv x y = lookupUFM x y
alterTyConEnv = alterUFM
mkTyConEnv l = listToUFM l
mkTyConEnvWith f = mkTyConEnv . map (\a -> (f a, a))
elemTyConEnv x y = elemUFM x y
plusTyConEnv x y = plusUFM x y
plusTyConEnv_C f x y = plusUFM_C f x y
plusTyConEnv_CD f x d y b = plusUFM_CD f x d y b
plusTyConEnv_CD2 f x y = plusUFM_CD2 f x y
extendTyConEnv_C f x y z = addToUFM_C f x y z
mapTyConEnv f x = mapUFM f x
extendTyConEnv_Acc x y z a b = addToUFM_Acc x y z a b
extendTyConEnvList_C x y z = addListToUFM_C x y z
delFromTyConEnv x y = delFromUFM x y
delListFromTyConEnv x y = delListFromUFM x y
filterTyConEnv x y = filterUFM x y
anyTyConEnv f x = foldUFM ((||) . f) False x
disjointTyConEnv x y = disjointUFM x y
lookupTyConEnv_NF env n = expectJust "lookupTyConEnv_NF" (lookupTyConEnv env n)
-- | Deterministic TyCon Environment
--
-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" for explanation why
-- we need DTyConEnv.
type DTyConEnv a = UniqDFM TyCon a
emptyDTyConEnv :: DTyConEnv a
emptyDTyConEnv = emptyUDFM
lookupDTyConEnv :: DTyConEnv a -> TyCon -> Maybe a
lookupDTyConEnv = lookupUDFM
delFromDTyConEnv :: DTyConEnv a -> TyCon -> DTyConEnv a
delFromDTyConEnv = delFromUDFM
filterDTyConEnv :: (a -> Bool) -> DTyConEnv a -> DTyConEnv a
filterDTyConEnv = filterUDFM
mapDTyConEnv :: (a -> b) -> DTyConEnv a -> DTyConEnv b
mapDTyConEnv = mapUDFM
adjustDTyConEnv :: (a -> a) -> DTyConEnv a -> TyCon -> DTyConEnv a
adjustDTyConEnv = adjustUDFM
alterDTyConEnv :: (Maybe a -> Maybe a) -> DTyConEnv a -> TyCon -> DTyConEnv a
alterDTyConEnv = alterUDFM
extendDTyConEnv :: DTyConEnv a -> TyCon -> a -> DTyConEnv a
extendDTyConEnv = addToUDFM
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
Check for recursive type constructors.
-}
{-# LANGUAGE CPP, DeriveDataTypeable #-}
module GHC.Core.TyCon.RecWalk (
-- * Recursion breaking
RecTcChecker, initRecTc, defaultRecTcMaxBound,
setRecTcMaxBound, checkRecTc
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Core.TyCon
import GHC.Core.TyCon.Env
{-
************************************************************************
* *
Walking over recursive TyCons
* *
************************************************************************
Note [Expanding newtypes and products]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When expanding a type to expose a data-type constructor, we need to be
careful about newtypes, lest we fall into an infinite loop. Here are
the key examples:
newtype Id x = MkId x
newtype Fix f = MkFix (f (Fix f))
newtype T = MkT (T -> T)
Type Expansion
--------------------------
T T -> T
Fix Maybe Maybe (Fix Maybe)
Id (Id Int) Int
Fix Id NO NO NO
Notice that
* We can expand T, even though it's recursive.
* We can expand Id (Id Int), even though the Id shows up
twice at the outer level, because Id is non-recursive
So, when expanding, we keep track of when we've seen a recursive
newtype at outermost level; and bail out if we see it again.
We sometimes want to do the same for product types, so that the
strictness analyser doesn't unbox infinitely deeply.
More precisely, we keep a *count* of how many times we've seen it.
This is to account for
data instance T (a,b) = MkT (T a) (T b)
Then (#10482) if we have a type like
T (Int,(Int,(Int,(Int,Int))))
we can still unbox deeply enough during strictness analysis.
We have to treat T as potentially recursive, but it's still
good to be able to unwrap multiple layers.
The function that manages all this is checkRecTc.
-}
data RecTcChecker = RC !Int (TyConEnv Int)
-- The upper bound, and the number of times
-- we have encountered each TyCon
-- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'.
initRecTc :: RecTcChecker
initRecTc = RC defaultRecTcMaxBound emptyTyConEnv
-- | The default upper bound (100) for the number of times a 'RecTcChecker' is
-- allowed to encounter each 'TyCon'.
defaultRecTcMaxBound :: Int
defaultRecTcMaxBound = 100
-- Should we have a flag for this?
-- | Change the upper bound for the number of times a 'RecTcChecker' is allowed
-- to encounter each 'TyCon'.
setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker
setRecTcMaxBound new_bound (RC _old_bound rec_nts) = RC new_bound rec_nts
checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker
-- Nothing => Recursion detected
-- Just rec_tcs => Keep going
checkRecTc (RC bound rec_nts) tc
= case lookupTyConEnv rec_nts tc of
Just n | n >= bound -> Nothing
| otherwise -> Just (RC bound (extendTyConEnv rec_nts tc (n+1)))
Nothing -> Just (RC bound (extendTyConEnv rec_nts tc 1))
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-}
{-# LANGUAGE CPP, DeriveDataTypeable #-}
module GHC.Core.TyCon.Set (
-- * TyCons set type
TyConSet,
-- ** Manipulating these sets
emptyTyConSet, unitTyConSet, mkTyConSet, unionTyConSet, unionTyConSets,
minusTyConSet, elemTyConSet, extendTyConSet, extendTyConSetList,
delFromTyConSet, delListFromTyConSet, isEmptyTyConSet, filterTyConSet,
intersectsTyConSet, disjointTyConSet, intersectTyConSet,
nameSetAny, nameSetAll
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Types.Unique.Set
import GHC.Core.TyCon (TyCon)
type TyConSet = UniqSet TyCon
emptyTyConSet :: TyConSet
unitTyConSet :: TyCon -> TyConSet
extendTyConSetList :: TyConSet -> [TyCon] -> TyConSet
extendTyConSet :: TyConSet -> TyCon -> TyConSet
mkTyConSet :: [TyCon] -> TyConSet
unionTyConSet :: TyConSet -> TyConSet -> TyConSet
unionTyConSets :: [TyConSet] -> TyConSet
minusTyConSet :: TyConSet -> TyConSet -> TyConSet
elemTyConSet :: TyCon -> TyConSet -> Bool
isEmptyTyConSet :: TyConSet -> Bool
delFromTyConSet :: TyConSet -> TyCon -> TyConSet
delListFromTyConSet :: TyConSet -> [TyCon] -> TyConSet
filterTyConSet :: (TyCon -> Bool) -> TyConSet -> TyConSet
intersectTyConSet :: TyConSet -> TyConSet -> TyConSet
intersectsTyConSet :: TyConSet -> TyConSet -> Bool
-- ^ True if there is a non-empty intersection.
-- @s1 `intersectsTyConSet` s2@ doesn't compute @s2@ if @s1@ is empty
disjointTyConSet :: TyConSet -> TyConSet -> Bool
isEmptyTyConSet = isEmptyUniqSet
emptyTyConSet = emptyUniqSet
unitTyConSet = unitUniqSet
mkTyConSet = mkUniqSet
extendTyConSetList = addListToUniqSet
extendTyConSet = addOneToUniqSet
unionTyConSet = unionUniqSets
unionTyConSets = unionManyUniqSets
minusTyConSet = minusUniqSet
elemTyConSet = elementOfUniqSet
delFromTyConSet = delOneFromUniqSet
filterTyConSet = filterUniqSet
intersectTyConSet = intersectUniqSets
disjointTyConSet = disjointUniqSets
delListFromTyConSet set ns = foldl' delFromTyConSet set ns
intersectsTyConSet s1 s2 = not (isEmptyTyConSet (s1 `intersectTyConSet` s2))
nameSetAny :: (TyCon -> Bool) -> TyConSet -> Bool
nameSetAny = uniqSetAny
nameSetAll :: (TyCon -> Bool) -> TyConSet -> Bool
nameSetAll = uniqSetAll
......@@ -67,6 +67,7 @@ import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.PatSyn
import GHC.Core.TyCon
import GHC.Core.TyCon.RecWalk
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim (tYPETyCon)
import GHC.Core.TyCo.Rep
......
......@@ -58,6 +58,7 @@ import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.TyCon.RecWalk
import GHC.Tc.Utils.TcType
import GHC.Builtin.Names
import GHC.Driver.Session
......
......@@ -174,6 +174,7 @@ import GHC.Core.Predicate
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.DFM
import GHC.Core.TyCon.Env
import GHC.Data.Maybe
import GHC.Core.Map
......@@ -2640,7 +2641,7 @@ delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a
delFunEq m tc tys = delTcApp m (getUnique tc) tys
------------------------------
type ExactFunEqMap a = UniqFM TyCon (ListMap TypeMap a)
type ExactFunEqMap a = TyConEnv (ListMap TypeMap a)
emptyExactFunEqs :: ExactFunEqMap a
emptyExactFunEqs = emptyUFM
......
......@@ -50,12 +50,13 @@ import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set hiding (unitFV)
import GHC.Types.Name.Reader ( mkVarUnqual )
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Unique.Set
import GHC.Core.TyCon.Set
import GHC.Core.Coercion ( ltRole )
import GHC.Types.Basic
import GHC.Types.SrcLoc
......@@ -156,7 +157,11 @@ newtype SynCycleM a = SynCycleM {
runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) }
deriving (Functor)
type SynCycleState = NameSet
-- TODO: TyConSet is implemented as IntMap over uniques.
-- But we could get away with something based on IntSet
-- since we only check membershib, but never extract the
-- elements.
type SynCycleState = TyConSet
instance Applicative SynCycleM where
pure x = SynCycleM $ \state -> Right (x, state)
......@@ -174,12 +179,12 @@ 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
checkTyConIsAcyclic :: TyCon -> SynCycleM () -> SynCycleM ()
checkTyConIsAcyclic tc m = SynCycleM $ \s ->
if tc `elemTyConSet` s
then Right ((), s) -- short circuit
else case runSynCycleM m s of
Right ((), s') -> Right ((), extendNameSet s' n)
Right ((), s') -> Right ((), extendTyConSet s' tc)
Left err -> Left err
-- | Checks if any of the passed in 'TyCon's have cycles.
......@@ -189,7 +194,7 @@ checkNameIsAcyclic n m = SynCycleM $ \s ->
-- can give better error messages.
checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM ()
checkSynCycles this_uid tcs tyclds = do
case runSynCycleM (mapM_ (go emptyNameSet []) tcs) emptyNameSet of
case runSynCycleM (mapM_ (go emptyTyConSet []) tcs) emptyTyConSet of
Left (loc, err) -> setSrcSpan loc $ failWithTc err
Right _ -> return ()
where
......@@ -198,15 +203,15 @@ checkSynCycles this_uid tcs tyclds = do
-- Short circuit if we've already seen this Name and concluded
-- it was acyclic.
go :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()
go :: TyConSet -> [TyCon] -> TyCon -> SynCycleM ()
go so_far seen_tcs tc =
checkNameIsAcyclic (tyConName tc) $ go' so_far seen_tcs tc
checkTyConIsAcyclic tc $ go' so_far seen_tcs tc
-- Expand type synonyms, complaining if you find the same
-- type synonym a second time.
go' :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()
go' :: TyConSet -> [TyCon] -> TyCon -> SynCycleM ()
go' so_far seen_tcs tc
| n `elemNameSet` so_far
| tc `elemTyConSet` so_far
= failSynCycleM (getSrcSpan (head seen_tcs)) $
sep [ text "Cycle in type synonym declarations:"
, nest 2 (vcat (map ppr_decl seen_tcs)) ]
......@@ -221,7 +226,7 @@ checkSynCycles this_uid tcs tyclds = do
isInteractiveModule mod)
= return ()
| Just ty <- synTyConRhs_maybe tc =
go_ty (extendNameSet so_far (tyConName tc)) (tc:seen_tcs) ty
go_ty (extendTyConSet so_far tc) (tc:seen_tcs) ty
| otherwise = return ()
where
n = tyConName tc
......@@ -234,7 +239,7 @@ checkSynCycles this_uid tcs tyclds = do
where
n = tyConName tc
go_ty :: NameSet -> [TyCon] -> Type -> SynCycleM ()
go_ty :: TyConSet -> [TyCon] -> Type -> SynCycleM ()
go_ty so_far seen_tcs ty =
mapM_ (go so_far seen_tcs) (synonymTyConsOfType ty)
......@@ -284,11 +289,13 @@ and now expand superclasses for constraint (C Id):
Each step expands superclasses one layer, and clearly does not terminate.
-}
type ClassSet = UniqSet Class
checkClassCycles :: Class -> Maybe SDoc
-- Nothing <=> ok
-- Just err <=> possible cycle error
checkClassCycles cls
= do { (definite_cycle, err) <- go (unitNameSet (getName cls))
= do { (definite_cycle, err) <- go (unitUniqSet cls)
cls (mkTyVarTys (classTyVars cls))
; let herald | definite_cycle = text "Superclass cycle for"
| otherwise = text "Potential superclass cycle for"
......@@ -304,12 +311,12 @@ checkClassCycles cls
-- NB: this code duplicates TcType.transSuperClasses, but
-- with more error message generation clobber
-- Make sure the two stay in sync.
go :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc)
go :: ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc)
go so_far cls tys = firstJusts $
map (go_pred so_far) $
immSuperClasses cls tys
go_pred :: NameSet -> PredType -> Maybe (Bool, SDoc)
go_pred :: ClassSet -> PredType -> Maybe (Bool, SDoc)
-- Nothing <=> ok
-- Just (True, err) <=> definite cycle
-- Just (False, err) <=> possible cycle
......@@ -322,7 +329,7 @@ checkClassCycles cls
| otherwise
= Nothing
go_tc :: NameSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc)
go_tc :: ClassSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc)
go_tc so_far pred tc tys
| isFamilyTyCon tc