Commit f4d37f05 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Comments only on superclass cycle check

parent 4fdd29ad
......@@ -112,40 +112,70 @@ mkSynEdges syn_decls = [ (ldecl, unLoc (tcdLName decl),
calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
calcSynCycles = stronglyConnCompFromEdgedVertices . mkSynEdges
\end{code}
Note [Superclass cycle check]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We can't allow cycles via superclasses because it would result in the
type checker looping when it canonicalises a class constraint (superclasses
are added during canonicalisation). More precisely, given a constraint
C ty1 .. tyn
we want to instantiate all of C's superclasses, transitively, and
that set must be finite. So if
class (D b, E b a) => C a b
then when we encounter the constraint
C ty1 ty2
we'll instantiate the superclasses
(D ty2, E ty2 ty1)
and then *their* superclasses, and so on. This set must be finite!
It is OK for superclasses to be type synonyms for other classes, so
must "look through" type synonyms. Eg
type X a = C [a]
class X a => C a -- No! Recursive superclass!
We want definitions such as:
class C cls a where cls a => a -> a
class C D a => D a where
to be accepted, even though a naive acyclicity check would reject the
program as having a cycle between D and its superclass. Why? Because
when we instantiate
D ty1
we get the superclas
C D ty1
and C has no superclasses, so we have terminated with a finite set.
More precisely, the rule is this: the superclasses sup_C of a class C
are rejected iff:
C \elem expand(sup_C)
Where expand is defined as follows:
-- We can't allow cycles via superclasses because it would result in the
-- type checker looping when it canonicalises a class constraint (superclasses
-- are added during canonicalisation)
--
-- It is OK for superclasses to be type synonyms for other classes, so look for cycles
-- through there too.
--
-- Note [Superclass cycle check]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- We want definitions such as:
--
-- class C cls a where cls a => a -> a
-- class C D a => D a where
--
-- To be accepted, even though a naive acyclicity check would reject the program as having
-- a cycle between D and its superclass.
--
-- The superclasses sup_C of a class C are rejected iff:
--
-- C \elem expand(sup_C)
--
-- Where expand is defined as follows:
--
-- expand(a ty1 ... tyN) = expand(ty1) \union ... \union expand(tyN)
-- expand(D ty1 ... tyN) = {D} \union sup_D[ty1/x1, ..., tyP/xP] \union expand(ty(P+1)) ... \union expand(tyN)
-- where (D x1 ... xM) is a class, P = min(M,N)
-- expand(T ty1 ... tyN) = expand(ty1) \union ... \union expand(tyN)
-- where T is not a class
--
-- Furthermore, expand always looks through type synonyms.
(1) expand(a ty1 ... tyN) = expand(ty1) \union ... \union expand(tyN)
(2) expand(D ty1 ... tyN) = {D}
\union sup_D[ty1/x1, ..., tyP/xP]
\union expand(ty(P+1)) ... \union expand(tyN)
where (D x1 ... xM) is a class, P = min(M,N)
(3) expand(T ty1 ... tyN) = expand(ty1) \union ... \union expand(tyN)
where T is not a class
Eqn (1) is conservative; when there's a type variable at the head,
look in all the argument types. Eqn (2) expands superclasses; the
third component of the union is like Eqn (1). Eqn (3) really never
happens.
Furthermore, expand always looks through type synonyms.
\begin{code}
calcClassCycles :: Class -> [[TyCon]]
calcClassCycles cls = nubBy eqAsCycle $ expandTheta (unitUniqSet cls) [classTyCon cls] (classSCTheta cls) []
calcClassCycles cls
= nubBy eqAsCycle $
expandTheta (unitUniqSet cls) [classTyCon cls] (classSCTheta cls) []
where
-- The last TyCon in the cycle is always the same as the first
eqAsCycle xs ys = any (xs ==) (cycles (tail ys))
......@@ -165,7 +195,8 @@ calcClassCycles cls = nubBy eqAsCycle $ expandTheta (unitUniqSet cls) [classTyCo
{-
expandTree seen path (ClassPred cls tys)
| cls `elemUniqSet` seen =
| otherwise = expandTheta (addOneToUniqSet cls seen) (classTyCon cls:path) (substTysWith (classTyVars cls) tys (classSCTheta cls))
| otherwise = expandTheta (addOneToUniqSet cls seen) (classTyCon cls:path)
(substTysWith (classTyVars cls) tys (classSCTheta cls))
expandTree seen path (TuplePred ts) = flip (foldr (expandTree seen path)) ts
expandTree _ _ (EqPred _ _) = id
expandTree _ _ (IPPred _ _) = id
......@@ -179,18 +210,26 @@ calcClassCycles cls = nubBy eqAsCycle $ expandTheta (unitUniqSet cls) [classTyCo
, let (env, remainder) = papp (classTyVars cls) tys
rest_tys = either (const []) id remainder
= if cls `elementOfUniqSet` seen
then (reverse (classTyCon cls:path):) . flip (foldr (expandType seen path)) tys
else expandTheta (addOneToUniqSet seen cls) (tc:path) (substTys (mkTopTvSubst env) (classSCTheta cls)) . flip (foldr (expandType seen path)) rest_tys
-- For synonyms, try to expand them: some arguments might be phantoms, after all. We can expand
-- with impunity because at this point the type synonym cycle check has already happened.
then (reverse (classTyCon cls:path):)
. flip (foldr (expandType seen path)) tys
else expandTheta (addOneToUniqSet seen cls) (tc:path)
(substTys (mkTopTvSubst env) (classSCTheta cls))
. flip (foldr (expandType seen path)) rest_tys
-- For synonyms, try to expand them: some arguments might be
-- phantoms, after all. We can expand with impunity because at
-- this point the type synonym cycle check has already happened.
| isSynTyCon tc
, SynonymTyCon rhs <- synTyConRhs tc
, let (env, remainder) = papp (tyConTyVars tc) tys
rest_tys = either (const []) id remainder
= expandType seen (tc:path) (substTy (mkTopTvSubst env) rhs) . flip (foldr (expandType seen path)) rest_tys
= expandType seen (tc:path) (substTy (mkTopTvSubst env) rhs)
. flip (foldr (expandType seen path)) rest_tys
-- For non-class, non-synonyms, just check the arguments
| otherwise
= flip (foldr (expandType seen path)) tys
expandType _ _ (TyVarTy _) = id
expandType seen path (AppTy t1 t2) = expandType seen path t1 . expandType seen path t2
expandType seen path (FunTy t1 t2) = expandType seen path t1 . expandType seen path t2
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment