Commit b8688dc7 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Test Trac #4903

parent 698f8220
......@@ -22,3 +22,9 @@ T4201:
'$(TEST_HC)' -c -O T4201.hs
'$(TEST_HC)' --show-iface T4201.hi | grep 'Unfolding.*sym'
# This one looped as a result of bogus specialisation
T4903:
$(RM) -f T4903a.o T4903.o
'$(TEST_HC)' -c -O T4903a.hs -dcore-lint
'$(TEST_HC)' -c -O T4903.hs -dcore-lint
module T4903 where
import T4903a
{-# SPECIALIZE eq :: TreeF Tree -> Tree -> Bool #-}
-- The pragma is only problematic if it is in a separate module
f :: Bool
-- If we don't use eq, there is no problem
f = eq Tree tree
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
module T4903a where
class El phi ix where
proof :: phi ix
class Fam phi where
from :: phi ix -> ix -> PF phi I0 ix
type family PF phi :: (* -> *) -> * -> *
data I0 a = I0 a
data I xi (r :: * -> *) ix = I (r xi)
data (f :*: g) (r :: * -> *) ix = f r ix :*: g r ix
class HEq phi f where
heq :: (forall ix. phi ix -> r ix -> Bool)
-> phi ix -> f r ix -> Bool
instance El phi xi => HEq phi (I xi) where
-- Replacing proof by undefined solves the problem
heq eq _ (I x) = eq proof x
instance (HEq phi f, HEq phi g) => HEq phi (f :*: g) where
-- The problem only arises when there are two calls to heq here
heq eq p (x :*: y) = heq eq p x && heq eq p y
{-# INLINABLE eq #-}
eq :: (Fam phi, HEq phi (PF phi)) => phi ix -> ix -> Bool
eq p x = heq (\p (I0 x) -> eq p x) p (from p x)
data Tree = Bin Tree Tree
tree :: Tree
-- The problem only occurs on an inifite (or very large) structure
tree = Bin tree tree
data TreeF :: * -> * where Tree :: TreeF Tree
type instance PF TreeF = I Tree :*: I Tree
-- If the representation is only |I Tree| then there is no problem
instance Fam TreeF where
from Tree (Bin l r) = I (I0 l) :*: I (I0 r)
instance El TreeF Tree where proof = Tree
......@@ -83,3 +83,8 @@ test('T3772',
test('T3831', normal, compile, [''])
test('T4345', normal, compile, [''])
test('T4398', normal, compile, [''])
test('T4903',
normal,
run_command,
['$MAKE -s --no-print-directory T4903'])
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