Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
f4d37f05
Commit
f4d37f05
authored
Oct 24, 2011
by
Simon Peyton Jones
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Comments only on superclass cycle check
parent
4fdd29ad
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
77 additions
and
38 deletions
+77
-38
compiler/typecheck/TcTyDecls.lhs
compiler/typecheck/TcTyDecls.lhs
+77
-38
No files found.
compiler/typecheck/TcTyDecls.lhs
View file @
f4d37f05
...
...
@@ -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
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment