Add some determinism tests

These are the tests that I accumulated fixing real issues.
Each test is a separate thing that was broken and they are
relatively small.

GHC Trac: #4012

40 files changed, 586 insertions, 0 deletions

diff --git a/testsuite/tests/determinism/determ007/A.hs b/testsuite/tests/determinism/determ007/A.hs
new file mode 100644
index 0000000000..9cc1705e45
--- /dev/null
+++ b/testsuite/tests/determinism/determ007/A.hs
@@ -0,0 +1,3 @@
+module A where
+
+data ADT a b = Z a b deriving Eq
diff --git a/testsuite/tests/determinism/determ007/Makefile b/testsuite/tests/determinism/determ007/Makefile
new file mode 100644
index 0000000000..c95e3f0fb9
--- /dev/null
+++ b/testsuite/tests/determinism/determ007/Makefile
@@ -0,0 +1,13 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS))
+
+determ007:
+	$(RM) A.hi A.o
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -O A.hs
+	$(CP) A.hi A.normal.hi
+	$(RM) A.hi A.o
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -O -dinitial-unique=16777215 -dunique-increment=-1 A.hs
+	diff A.hi A.normal.hi
diff --git a/testsuite/tests/determinism/determ007/all.T b/testsuite/tests/determinism/determ007/all.T
new file mode 100644
index 0000000000..6d818588ba
--- /dev/null
+++ b/testsuite/tests/determinism/determ007/all.T
@@ -0,0 +1,4 @@
+test('determ007',
+     extra_clean(['A.o', 'A.hi', 'A.normal.hi']),
+     run_command,
+     ['$MAKE -s --no-print-directory determ007'])
diff --git a/testsuite/tests/determinism/determ007/determ007.stdout b/testsuite/tests/determinism/determ007/determ007.stdout
new file mode 100644
index 0000000000..60c2bc368d
--- /dev/null
+++ b/testsuite/tests/determinism/determ007/determ007.stdout
@@ -0,0 +1,2 @@
+[1 of 1] Compiling A                ( A.hs, A.o )
+[1 of 1] Compiling A                ( A.hs, A.o )
diff --git a/testsuite/tests/determinism/determ008/A.hs b/testsuite/tests/determinism/determ008/A.hs
new file mode 100644
index 0000000000..df61b65108
--- /dev/null
+++ b/testsuite/tests/determinism/determ008/A.hs
@@ -0,0 +1,3 @@
+module A where
+
+data F a b = F { x :: !Int, y :: !(Float,Float), z :: !(a,b) }
diff --git a/testsuite/tests/determinism/determ008/Makefile b/testsuite/tests/determinism/determ008/Makefile
new file mode 100644
index 0000000000..eec3bccb0d
--- /dev/null
+++ b/testsuite/tests/determinism/determ008/Makefile
@@ -0,0 +1,13 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS))
+
+determ008:
+	$(RM) A.hi A.o
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -O A.hs
+	$(CP) A.hi A.normal.hi
+	$(RM) A.hi A.o
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -O -dinitial-unique=16777215 -dunique-increment=-1 A.hs
+	diff A.hi A.normal.hi
diff --git a/testsuite/tests/determinism/determ008/all.T b/testsuite/tests/determinism/determ008/all.T
new file mode 100644
index 0000000000..af4d8d7948
--- /dev/null
+++ b/testsuite/tests/determinism/determ008/all.T
@@ -0,0 +1,4 @@
+test('determ008',
+     extra_clean(['A.o', 'A.hi', 'A.normal.hi']),
+     run_command,
+     ['$MAKE -s --no-print-directory determ008'])
diff --git a/testsuite/tests/determinism/determ008/determ008.stdout b/testsuite/tests/determinism/determ008/determ008.stdout
new file mode 100644
index 0000000000..60c2bc368d
--- /dev/null
+++ b/testsuite/tests/determinism/determ008/determ008.stdout
@@ -0,0 +1,2 @@
+[1 of 1] Compiling A                ( A.hs, A.o )
+[1 of 1] Compiling A                ( A.hs, A.o )
diff --git a/testsuite/tests/determinism/determ009/A.hs b/testsuite/tests/determinism/determ009/A.hs
new file mode 100644
index 0000000000..4a8de21bc0
--- /dev/null
+++ b/testsuite/tests/determinism/determ009/A.hs
@@ -0,0 +1,4 @@
+module A where
+
+newtype Pair1 f g a = Pair1 {unPair1 :: (f a, g a)}
+  deriving Eq
diff --git a/testsuite/tests/determinism/determ009/Makefile b/testsuite/tests/determinism/determ009/Makefile
new file mode 100644
index 0000000000..caceae48b6
--- /dev/null
+++ b/testsuite/tests/determinism/determ009/Makefile
@@ -0,0 +1,13 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS))
+
+determ009:
+	$(RM) A.hi A.o
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=0 -dunique-increment=1 A.hs
+	$(CP) A.hi A.normal.hi
+	$(RM) A.hi A.o
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=16777215 -dunique-increment=-1 A.hs
+	diff A.hi A.normal.hi
diff --git a/testsuite/tests/determinism/determ009/all.T b/testsuite/tests/determinism/determ009/all.T
new file mode 100644
index 0000000000..7cae393162
--- /dev/null
+++ b/testsuite/tests/determinism/determ009/all.T
@@ -0,0 +1,4 @@
+test('determ009',
+     extra_clean(['A.o', 'A.hi', 'A.normal.hi']),
+     run_command,
+     ['$MAKE -s --no-print-directory determ009'])
diff --git a/testsuite/tests/determinism/determ009/determ009.stdout b/testsuite/tests/determinism/determ009/determ009.stdout
new file mode 100644
index 0000000000..60c2bc368d
--- /dev/null
+++ b/testsuite/tests/determinism/determ009/determ009.stdout
@@ -0,0 +1,2 @@
+[1 of 1] Compiling A                ( A.hs, A.o )
+[1 of 1] Compiling A                ( A.hs, A.o )
diff --git a/testsuite/tests/determinism/determ011/A.hs b/testsuite/tests/determinism/determ011/A.hs
new file mode 100644
index 0000000000..6e65c8ddce
--- /dev/null
+++ b/testsuite/tests/determinism/determ011/A.hs
@@ -0,0 +1,26 @@
+module A where
+
+-- Reproduces an issue where rules would abstract over typeclass dictionaries
+-- non-deterministically.
+--
+-- Compare:
+--
+-- RULES: "SPECLOL $csize" [ALWAYS]
+--            forall ($dOrd_a1sc :: Ord Int) ($dNum_a1sd :: Num Int).
+--              $csize_a1sg @ Int $dOrd_a1sc $dNum_a1sd
+--              = $s$csize_d1zr]
+-- with:
+--
+-- RULES: "SPEC $csize" [ALWAYS]
+--            forall ($dNum_a18n42 :: Num Int) ($dOrd_a18n43 :: Ord Int).
+--              $csize_a18n3Z @ Int $dOrd_a18n43 $dNum_a18n42
+--              = $s$csize_d18mWO]
+
+class Size t where
+  size :: t -> t -> Int
+
+instance (Ord a, Num a) => Size [a] where
+  {-# SPECIALISE instance Size [Int] #-}
+  size (x:xs) (y:ys) | x+y > 4   = size xs ys
+                     | otherwise = size xs ys
+  size _ _ = 0
diff --git a/testsuite/tests/determinism/determ011/Makefile b/testsuite/tests/determinism/determ011/Makefile
new file mode 100644
index 0000000000..f50ed595ab
--- /dev/null
+++ b/testsuite/tests/determinism/determ011/Makefile
@@ -0,0 +1,13 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS))
+
+determ011:
+	$(RM) A.hi A.o
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=0 -dunique-increment=1 -O A.hs
+	$(CP) A.hi A.normal.hi
+	$(RM) A.hi A.o
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=16777215 -dunique-increment=-1 -O A.hs
+	diff A.hi A.normal.hi
diff --git a/testsuite/tests/determinism/determ011/all.T b/testsuite/tests/determinism/determ011/all.T
new file mode 100644
index 0000000000..ba9ef62a18
--- /dev/null
+++ b/testsuite/tests/determinism/determ011/all.T
@@ -0,0 +1,4 @@
+test('determ011',
+     extra_clean(['A.o', 'A.hi', 'A.normal.hi']),
+     run_command,
+     ['$MAKE -s --no-print-directory determ011'])
diff --git a/testsuite/tests/determinism/determ011/determ011.stdout b/testsuite/tests/determinism/determ011/determ011.stdout
new file mode 100644
index 0000000000..60c2bc368d
--- /dev/null
+++ b/testsuite/tests/determinism/determ011/determ011.stdout
@@ -0,0 +1,2 @@
+[1 of 1] Compiling A                ( A.hs, A.o )
+[1 of 1] Compiling A                ( A.hs, A.o )
diff --git a/testsuite/tests/determinism/determ012/A.hs b/testsuite/tests/determinism/determ012/A.hs
new file mode 100644
index 0000000000..a61b2bc294
--- /dev/null
+++ b/testsuite/tests/determinism/determ012/A.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE PolyKinds, MultiParamTypeClasses, FunctionalDependencies,
+             UndecidableInstances, FlexibleInstances #-}
+
+module T10109 where
+
+data Succ a
+
+class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab
+instance (Add a b ab) => Add (Succ a) b (Succ ab)
+
diff --git a/testsuite/tests/determinism/determ012/Makefile b/testsuite/tests/determinism/determ012/Makefile
new file mode 100644
index 0000000000..307d9b57fe
--- /dev/null
+++ b/testsuite/tests/determinism/determ012/Makefile
@@ -0,0 +1,13 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS))
+
+determ012:
+	$(RM) A.hi A.o
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=0 -dunique-increment=1 -O A.hs
+	$(CP) A.hi A.normal.hi
+	$(RM) A.hi A.o
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=16777215 -dunique-increment=-1 -O A.hs
+	diff A.hi A.normal.hi
diff --git a/testsuite/tests/determinism/determ012/all.T b/testsuite/tests/determinism/determ012/all.T
new file mode 100644
index 0000000000..f493d4241b
--- /dev/null
+++ b/testsuite/tests/determinism/determ012/all.T
@@ -0,0 +1,4 @@
+test('determ012',
+     extra_clean(['A.o', 'A.hi', 'A.normal.hi']),
+     run_command,
+     ['$MAKE -s --no-print-directory determ012'])
diff --git a/testsuite/tests/determinism/determ012/determ012.stdout b/testsuite/tests/determinism/determ012/determ012.stdout
new file mode 100644
index 0000000000..713550b6a3
--- /dev/null
+++ b/testsuite/tests/determinism/determ012/determ012.stdout
@@ -0,0 +1,2 @@
+[1 of 1] Compiling T10109           ( A.hs, A.o )
+[1 of 1] Compiling T10109           ( A.hs, A.o )
diff --git a/testsuite/tests/determinism/determ013/A.hs b/testsuite/tests/determinism/determ013/A.hs
new file mode 100644
index 0000000000..e2415a7f95
--- /dev/null
+++ b/testsuite/tests/determinism/determ013/A.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE DataKinds, PolyKinds, TypeFamilies, TypeOperators,
+             UndecidableInstances #-}
+
+module T9063 where
+
+import Data.Type.Equality
+import Data.Proxy
+
+-- reproduces an issue where type variables in the axiom are in
+-- non-deterministic order
+
+class kproxy ~ 'KProxy => PEq (kproxy :: KProxy a) where
+  type FunnyEq (x :: a) (y :: a) :: Bool
+  type FunnyEq x y = x == y
+
+instance PEq ('KProxy :: KProxy Bool)
+
+foo :: Proxy (FunnyEq True True) -> Proxy (True == True)
+foo = id
diff --git a/testsuite/tests/determinism/determ013/Makefile b/testsuite/tests/determinism/determ013/Makefile
new file mode 100644
index 0000000000..a28a13fa36
--- /dev/null
+++ b/testsuite/tests/determinism/determ013/Makefile
@@ -0,0 +1,13 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS))
+
+determ013:
+	$(RM) A.hi A.o
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=0 -dunique-increment=1 -O A.hs
+	$(CP) A.hi A.normal.hi
+	$(RM) A.hi A.o
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=16777215 -dunique-increment=-1 -O A.hs
+	diff A.hi A.normal.hi
diff --git a/testsuite/tests/determinism/determ013/all.T b/testsuite/tests/determinism/determ013/all.T
new file mode 100644
index 0000000000..0804f039a6
--- /dev/null
+++ b/testsuite/tests/determinism/determ013/all.T
@@ -0,0 +1,4 @@
+test('determ013',
+     extra_clean(['A.o', 'A.hi', 'A.normal.hi']),
+     run_command,
+     ['$MAKE -s --no-print-directory determ013'])
diff --git a/testsuite/tests/determinism/determ013/determ013.stdout b/testsuite/tests/determinism/determ013/determ013.stdout
new file mode 100644
index 0000000000..103261b5bc
--- /dev/null
+++ b/testsuite/tests/determinism/determ013/determ013.stdout
@@ -0,0 +1,2 @@
+[1 of 1] Compiling T9063            ( A.hs, A.o )
+[1 of 1] Compiling T9063            ( A.hs, A.o )
diff --git a/testsuite/tests/determinism/determ014/A.hs b/testsuite/tests/determinism/determ014/A.hs
new file mode 100644
index 0000000000..fb7a538ebd
--- /dev/null
+++ b/testsuite/tests/determinism/determ014/A.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE
+    ScopedTypeVariables
+  , DataKinds
+  , GADTs
+  , RankNTypes
+  , TypeOperators
+  , PolyKinds -- Comment out PolyKinds and the bug goes away.
+  #-}
+{-# OPTIONS_GHC -O #-}
+  -- The bug is in SimplUtils.abstractFloats, so we need -O to trigger it
+
+module KeyValue where
+
+data AccValidation err a = AccFailure err | AccSuccess a
+
+data KeyValueError = MissingValue
+
+type WithKeyValueError = AccValidation [KeyValueError]
+
+missing :: forall f rs. RecApplicative rs => Rec (WithKeyValueError :. f) rs
+missing = rpure missingField
+  where
+    missingField :: forall x. (WithKeyValueError :. f) x
+    missingField = Compose $ AccFailure [MissingValue]
+
+data Rec :: (u -> *) -> [u] -> * where
+  RNil :: Rec f '[]
+  (:&) :: !(f r) -> !(Rec f rs) -> Rec f (r ': rs)
+
+newtype Compose (f :: l -> *) (g :: k -> l) (x :: k)
+  = Compose { getCompose :: f (g x) }
+
+type (:.) f g = Compose f g
+
+class RecApplicative rs where
+  rpure
+    :: (forall x. f x)
+    -> Rec f rs
diff --git a/testsuite/tests/determinism/determ014/Makefile b/testsuite/tests/determinism/determ014/Makefile
new file mode 100644
index 0000000000..d170232d76
--- /dev/null
+++ b/testsuite/tests/determinism/determ014/Makefile
@@ -0,0 +1,13 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS))
+
+determ014:
+	$(RM) A.hi A.o
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=0 -dunique-increment=1 -O A.hs
+	$(CP) A.hi A.normal.hi
+	$(RM) A.hi A.o
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=16777215 -dunique-increment=-1 -O A.hs
+	diff A.hi A.normal.hi
diff --git a/testsuite/tests/determinism/determ014/all.T b/testsuite/tests/determinism/determ014/all.T
new file mode 100644
index 0000000000..4d376f2d99
--- /dev/null
+++ b/testsuite/tests/determinism/determ014/all.T
@@ -0,0 +1,4 @@
+test('determ014',
+     extra_clean(['A.o', 'A.hi', 'A.normal.hi']),
+     run_command,
+     ['$MAKE -s --no-print-directory determ014'])
diff --git a/testsuite/tests/determinism/determ014/determ014.stdout b/testsuite/tests/determinism/determ014/determ014.stdout
new file mode 100644
index 0000000000..2607792b31
--- /dev/null
+++ b/testsuite/tests/determinism/determ014/determ014.stdout
@@ -0,0 +1,2 @@
+[1 of 1] Compiling KeyValue         ( A.hs, A.o )
+[1 of 1] Compiling KeyValue         ( A.hs, A.o )
diff --git a/testsuite/tests/determinism/determ015/A.hs b/testsuite/tests/determinism/determ015/A.hs
new file mode 100644
index 0000000000..14b29170b1
--- /dev/null
+++ b/testsuite/tests/determinism/determ015/A.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE UnicodeSyntax #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module A where
+
+infixr 7 :*
+infix  8 :*:
+
+data HNil
+data α :* β
+type HSingle α = α :* HNil
+type α :*: β = α :* β :* HNil
+
+data HList l where
+  HNil  ∷ HList HNil
+  (:*) ∷ α → HList t → HList (α :* t)
+
+data First
+data Next p
+
+data HIndex i where
+  First ∷ HIndex First
+  Next  ∷ HIndex p → HIndex (Next p)
+
+class (l ~ (HHead l :* HTail l)) ⇒ HNonEmpty l where
+  type HHead l
+  type HTail l
+
+instance HNonEmpty (h :* t) where
+  type HHead (h :* t) = h
+  type HTail (h :* t) = t
+
+data HFromWitness n l where
+  HFromFirst ∷ HFromWitness First l
+  HFromNext  ∷ (HNonEmpty l, HFromClass p (HTail l),
+                HTail (HFrom (Next p) l) ~ HFrom (Next p) (HTail l))
+             ⇒ HFromWitness (Next p) l
+
+class HFromClass n l where
+  type HFrom n l
+  hFromWitness ∷ HFromWitness n l
+
+instance HFromClass First l where
+  type HFrom First l = l
+  hFromWitness = HFromFirst
+
+instance (HNonEmpty l, HFromClass p (HTail l)) ⇒ HFromClass (Next p) l where
+  type HFrom (Next p) l = HFrom p (HTail l)
+  hFromWitness = case hFromWitness ∷ HFromWitness p (HTail l) of
+    HFromFirst → HFromNext
+    HFromNext  → HFromNext
diff --git a/testsuite/tests/determinism/determ015/Makefile b/testsuite/tests/determinism/determ015/Makefile
new file mode 100644
index 0000000000..4ba32f0e02
--- /dev/null
+++ b/testsuite/tests/determinism/determ015/Makefile
@@ -0,0 +1,13 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS))
+
+determ015:
+	$(RM) A.hi A.o
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=0 -dunique-increment=1 -O A.hs
+	$(CP) A.hi A.normal.hi
+	$(RM) A.hi A.o
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=16777215 -dunique-increment=-1 -O A.hs
+	diff A.hi A.normal.hi
diff --git a/testsuite/tests/determinism/determ015/all.T b/testsuite/tests/determinism/determ015/all.T
new file mode 100644
index 0000000000..e4d65f43b3
--- /dev/null
+++ b/testsuite/tests/determinism/determ015/all.T
@@ -0,0 +1,4 @@
+test('determ015',
+     extra_clean(['A.o', 'A.hi', 'A.normal.hi']),
+     run_command,
+     ['$MAKE -s --no-print-directory determ015'])
diff --git a/testsuite/tests/determinism/determ015/determ015.stdout b/testsuite/tests/determinism/determ015/determ015.stdout
new file mode 100644
index 0000000000..60c2bc368d
--- /dev/null
+++ b/testsuite/tests/determinism/determ015/determ015.stdout
@@ -0,0 +1,2 @@
+[1 of 1] Compiling A                ( A.hs, A.o )
+[1 of 1] Compiling A                ( A.hs, A.o )
diff --git a/testsuite/tests/determinism/determ016/A.hs b/testsuite/tests/determinism/determ016/A.hs
new file mode 100644
index 0000000000..81aa34d66d
--- /dev/null
+++ b/testsuite/tests/determinism/determ016/A.hs
@@ -0,0 +1,19 @@
+
+{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses, FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# OPTIONS -w #-}
+
+module A where
+
+data PSum a b = Empty | Tree a b [(PSum a b)]
+
+extractMinX ∷ (Ord a, Eq b, Num b) ⇒ PSum a b → ((a,b), PSum a b)
+extractMinX Empty = undefined
+extractMinX (Tree v r xs) = ((v,r), Empty)
+
+toListX ∷ (Ord a, Eq b, Num b) ⇒ PSum a b → [(a,b)]
+toListX Empty = []
+toListX x = let (y, z) = extractMinX x in y : toListX z
+
+main ∷ IO ()
+main = print $ take 20 $ toListX $ (Empty :: PSum Int Int)
diff --git a/testsuite/tests/determinism/determ016/Makefile b/testsuite/tests/determinism/determ016/Makefile
new file mode 100644
index 0000000000..f6d0009fbb
--- /dev/null
+++ b/testsuite/tests/determinism/determ016/Makefile
@@ -0,0 +1,13 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS))
+
+determ016:
+	$(RM) A.hi A.o 
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=0 -dunique-increment=1 -O A.hs
+	$(CP) A.hi A.normal.hi
+	$(RM) A.hi A.o 
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=16777215 -dunique-increment=-1 -O A.hs
+	diff A.hi A.normal.hi
diff --git a/testsuite/tests/determinism/determ016/all.T b/testsuite/tests/determinism/determ016/all.T
new file mode 100644
index 0000000000..40fa202002
--- /dev/null
+++ b/testsuite/tests/determinism/determ016/all.T
@@ -0,0 +1,4 @@
+test('determ016',
+     extra_clean(['A.o', 'A.hi', 'A.normal.hi']),
+     run_command,
+     ['$MAKE -s --no-print-directory determ016'])
diff --git a/testsuite/tests/determinism/determ016/determ016.stdout b/testsuite/tests/determinism/determ016/determ016.stdout
new file mode 100644
index 0000000000..60c2bc368d
--- /dev/null
+++ b/testsuite/tests/determinism/determ016/determ016.stdout
@@ -0,0 +1,2 @@
+[1 of 1] Compiling A                ( A.hs, A.o )
+[1 of 1] Compiling A                ( A.hs, A.o )
diff --git a/testsuite/tests/determinism/determ017/A.hs b/testsuite/tests/determinism/determ017/A.hs
new file mode 100644
index 0000000000..2540be4b29
--- /dev/null
+++ b/testsuite/tests/determinism/determ017/A.hs
@@ -0,0 +1,215 @@
+{-
+    Copyright 2009 Mario Blazevic
+
+    This file is part of the Streaming Component Combinators (SCC) project.
+
+    The SCC project is free software: you can redistribute it and/or
+    modify it under the terms of the GNU General Public License as
+    published by the Free Software Foundation, either version 3 of the
+    License, or (at your option) any later version.
+
+    SCC is distributed in the hope that it will be useful, but WITHOUT
+    ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+    or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
+    License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with SCC.  If not, see <http://www.gnu.org/licenses/>.
+-}
+
+-- | Module "Trampoline" defines the pipe computations and their basic building blocks.
+
+{-# LANGUAGE ScopedTypeVariables, Rank2Types, MultiParamTypeClasses,
+             TypeFamilies, KindSignatures, FlexibleContexts,
+             FlexibleInstances, OverlappingInstances, UndecidableInstances
+ #-}
+
+{-   Somewhere we get:
+
+  Wanted: AncestorFunctor (EitherFunctor a (TryYield a)) d
+  This should not reduce because of overlapping instances
+
+  If it (erroneously) does reduce, via dfun2 we get
+  Wanted: Functor (EitherFunctor a (TryYield a)
+          Functor d'
+          Functor d
+          d ~ EitherFunctor d' s
+          AncestorFunctor (EitherFunctor a (TryYield a) d'
+
+
+  And that gives an infinite loop in the type checker!
+-}
+
+{-# OPTIONS -w #-}
+
+module A where
+
+import Control.Monad (liftM, liftM2, when, ap)
+-- import Control.Monad.Identity
+
+import Debug.Trace (trace)
+
+
+-------------
+class (Functor a, Functor d) => AncestorFunctor a d where
+   liftFunctor :: a x -> d x
+
+-- dfun 1
+instance Functor a => AncestorFunctor a a where
+   liftFunctor = trace "liftFunctor id" . id
+
+-- dfun 2
+instance ( Functor a
+         , Functor d'
+         , Functor d
+         , d ~ EitherFunctor d' s
+         , AncestorFunctor a d')
+      => AncestorFunctor a d where
+   liftFunctor = LeftF . (trace "liftFunctor other" . liftFunctor :: a x -> d' x)
+
+-------------
+newtype Identity a = Identity { runIdentity :: a }
+
+instance Functor Identity where
+    fmap = liftM
+
+instance Applicative Identity where
+    pure  = return
+    (<*>) = ap
+
+instance Monad Identity where
+    return a = Identity a
+    m >>= k  = k (runIdentity m)
+
+newtype Trampoline m s r = Trampoline {bounce :: m (TrampolineState m s r)}
+data TrampolineState m s r = Done r | Suspend! (s (Trampoline m s r))
+
+instance (Monad m, Functor s) => Functor (Trampoline m s) where
+  fmap = liftM
+
+instance (Monad m, Functor s) => Applicative (Trampoline m s) where
+  pure  = return
+  (<*>) = ap
+
+instance (Monad m, Functor s) => Monad (Trampoline m s) where
+   return x = Trampoline (return (Done x))
+   t >>= f = Trampoline (bounce t >>= apply f)
+      where apply f (Done x) = bounce (f x)
+            apply f (Suspend s) = return (Suspend (fmap (>>= f) s))
+
+data Yield x y = Yield! x y
+instance Functor (Yield x) where
+   fmap f (Yield x y) = trace "fmap yield" $ Yield x (f y)
+
+data Await x y = Await! (x -> y)
+instance Functor (Await x) where
+   fmap f (Await g) = trace "fmap await" $ Await (f . g)
+
+data EitherFunctor l r x = LeftF (l x) | RightF (r x)
+instance (Functor l, Functor r) => Functor (EitherFunctor l r) where
+   fmap f v = trace "fmap Either" $
+              case v of
+                LeftF l  -> trace "fmap LeftF" $ LeftF (fmap f l)
+                RightF r -> trace "fmap RightF" $ RightF (fmap f r)
+
+type TryYield x = EitherFunctor (Yield x) (Await Bool)
+
+suspend :: (Monad m, Functor s) => s (Trampoline m s x) -> Trampoline m s x
+suspend s = Trampoline (return (Suspend s))
+
+yield :: forall m x. Monad m => x -> Trampoline m (Yield x) ()
+yield x = suspend (Yield x (return ()))
+
+await :: forall m x. Monad m => Trampoline m (Await x) x
+await = suspend (Await return)
+
+tryYield :: forall m x. Monad m => x -> Trampoline m (TryYield x) Bool
+tryYield x = suspend (LeftF (Yield x (suspend (RightF (Await return)))))
+
+canYield :: forall m x. Monad m => Trampoline m (TryYield x) Bool
+canYield = suspend (RightF (Await return))
+
+liftBounce :: Monad m => m x -> Trampoline m s x
+liftBounce = Trampoline . liftM Done
+
+fromTrampoline :: Monad m => Trampoline m s x -> m x
+fromTrampoline t = bounce t >>= \(Done x)-> return x
+
+runTrampoline :: Monad m => Trampoline m Maybe x -> m x
+runTrampoline = fromTrampoline
+
+coupleNestedFinite :: (Functor s, Monad m) =>
+                      Trampoline m (EitherFunctor s (TryYield a)) x
+                   -> Trampoline m (EitherFunctor s (Await (Maybe a))) y -> Trampoline m s (x, y)
+coupleNestedFinite t1 t2 =
+   trace "bounce start" $
+   liftBounce (liftM2 (,) (bounce t1) (bounce t2))
+   >>= \(s1, s2)-> trace "bounce end" $
+                   case (s1, s2)
+                   of (Done x, Done y) -> return (x, y)
+                      (Done x, Suspend (RightF (Await c2))) -> coupleNestedFinite (return x) (c2 Nothing)
+                      (Suspend (RightF (LeftF (Yield _ c1))), Done y) -> coupleNestedFinite c1 (return y)
+                      (Suspend (RightF (LeftF (Yield x c1))), Suspend (RightF (Await c2))) -> coupleNestedFinite c1 (c2 $ Just x)
+                      (Suspend (RightF (RightF (Await c1))), Suspend s2@(RightF Await{})) -> coupleNestedFinite (c1 True) (suspend s2)
+                      (Suspend (RightF (RightF (Await c1))), Done y) -> coupleNestedFinite (c1 False) (return y)
+                      (Suspend (LeftF s), Done y) -> suspend (fmap (flip coupleNestedFinite (return y)) s)
+                      (Done x, Suspend (LeftF s)) -> suspend (fmap (coupleNestedFinite (return x)) s)
+                      (Suspend (LeftF s1), Suspend (LeftF s2)) -> suspend (fmap (coupleNestedFinite $ suspend $ LeftF s1) s2)
+                      (Suspend (LeftF s1), Suspend (RightF s2)) -> suspend (fmap (flip coupleNestedFinite (suspend $ RightF s2)) s1)
+                      (Suspend (RightF s1), Suspend (LeftF s2)) -> suspend (fmap (coupleNestedFinite (suspend $ RightF s1)) s2)
+
+local :: forall m l r x. (Monad m, Functor r) => Trampoline m r x -> Trampoline m (EitherFunctor l r) x
+local (Trampoline mr) = Trampoline (liftM inject mr)
+   where inject :: TrampolineState m r x -> TrampolineState m (EitherFunctor l r) x
+         inject (Done x) = Done x
+         inject (Suspend r) = Suspend (RightF $ fmap local r)
+
+out :: forall m l r x. (Monad m, Functor l) => Trampoline m l x -> Trampoline m (EitherFunctor l r) x
+out (Trampoline ml) = Trampoline (liftM inject ml)
+   where inject :: TrampolineState m l x -> TrampolineState m (EitherFunctor l r) x
+         inject (Done x) = Done x
+         inject (Suspend l) = Suspend (LeftF $ fmap out l)
+
+liftOut :: forall m a d x. (Monad m, Functor a, AncestorFunctor a d) => Trampoline m a x -> Trampoline m d x
+liftOut (Trampoline ma) = trace "liftOut" $ Trampoline (liftM inject ma)
+   where inject :: TrampolineState m a x -> TrampolineState m d x
+         inject (Done x) = Done x
+         inject (Suspend a) = trace "inject suspend" $ Suspend (liftFunctor $ trace "calling fmap" $
+                              fmap liftOut (trace "poking a" a))
+
+data Sink (m :: * -> *) a x =
+   Sink   {put :: forall d. (AncestorFunctor (EitherFunctor a (TryYield x)) d) => x -> Trampoline m d Bool,
+           canPut :: forall d. (AncestorFunctor (EitherFunctor a (TryYield x)) d) => Trampoline m d Bool}
+newtype Source (m :: * -> *) a x =
+   Source {get :: forall d. (AncestorFunctor (EitherFunctor a (Await (Maybe x))) d) => Trampoline m d (Maybe x)}
+
+pipe :: forall m a x r1 r2. (Monad m, Functor a) =>
+        (Sink m a x -> Trampoline m (EitherFunctor a (TryYield x)) r1)
+     -> (Source m a x -> Trampoline m (EitherFunctor a (Await (Maybe x))) r2) -> Trampoline m a (r1, r2)
+pipe producer consumer = coupleNestedFinite (producer sink) (consumer source) where
+   sink = Sink {put= liftOut . (local . tryYield :: x -> Trampoline m (EitherFunctor a (TryYield x)) Bool),
+                canPut= liftOut (local canYield :: Trampoline m (EitherFunctor a (TryYield x)) Bool)} :: Sink m a x
+   source = Source (liftOut (local await :: Trampoline m (EitherFunctor a (Await (Maybe x))) (Maybe x))) :: Source m a x
+
+pipeProducer sink = do put sink 1
+                       (c, d) <- pipe
+                                    (\sink'-> do put sink' 2
+                                                 put sink 3
+                                                 put sink' 4
+                                                 return 5)
+                                    (\source'-> do Just n <- get source'
+                                                   put sink n
+                                                   put sink 6
+                                                   return n)
+                       put sink c
+                       put sink d
+                       return (c, d)
+
+testPipe = print $
+           runIdentity $
+           runTrampoline $
+           do (a, b) <- pipe
+                           pipeProducer
+                           (\source-> do Just n1 <- get source
+                                         return (n1, n1, n1))
+              return (a, b)
diff --git a/testsuite/tests/determinism/determ017/Makefile b/testsuite/tests/determinism/determ017/Makefile
new file mode 100644
index 0000000000..6881e4318a
--- /dev/null
+++ b/testsuite/tests/determinism/determ017/Makefile
@@ -0,0 +1,13 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS))
+
+determ017:
+	$(RM) A.hi A.o 
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=0 -dunique-increment=1 -O A.hs
+	$(CP) A.hi A.normal.hi
+	$(RM) A.hi A.o 
+	'$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=16777215 -dunique-increment=-1 -O A.hs
+	diff A.hi A.normal.hi
diff --git a/testsuite/tests/determinism/determ017/all.T b/testsuite/tests/determinism/determ017/all.T
new file mode 100644
index 0000000000..8bff33b1fd
--- /dev/null
+++ b/testsuite/tests/determinism/determ017/all.T
@@ -0,0 +1,4 @@
+test('determ017',
+     extra_clean(['A.o', 'A.hi', 'A.normal.hi']),
+     run_command,
+     ['$MAKE -s --no-print-directory determ017'])
diff --git a/testsuite/tests/determinism/determ017/determ017.stdout b/testsuite/tests/determinism/determ017/determ017.stdout
new file mode 100644
index 0000000000..60c2bc368d
--- /dev/null
+++ b/testsuite/tests/determinism/determ017/determ017.stdout
@@ -0,0 +1,2 @@
+[1 of 1] Compiling A                ( A.hs, A.o )
+[1 of 1] Compiling A                ( A.hs, A.o )