summaryrefslogtreecommitdiff
path: root/testsuite
diff options
context:
space:
mode:
Diffstat (limited to 'testsuite')
-rw-r--r--testsuite/driver/extra_files.py10
-rw-r--r--testsuite/tests/determinism/determ007/A.hs3
-rw-r--r--testsuite/tests/determinism/determ007/Makefile13
-rw-r--r--testsuite/tests/determinism/determ007/all.T4
-rw-r--r--testsuite/tests/determinism/determ007/determ007.stdout2
-rw-r--r--testsuite/tests/determinism/determ008/A.hs3
-rw-r--r--testsuite/tests/determinism/determ008/Makefile13
-rw-r--r--testsuite/tests/determinism/determ008/all.T4
-rw-r--r--testsuite/tests/determinism/determ008/determ008.stdout2
-rw-r--r--testsuite/tests/determinism/determ009/A.hs4
-rw-r--r--testsuite/tests/determinism/determ009/Makefile13
-rw-r--r--testsuite/tests/determinism/determ009/all.T4
-rw-r--r--testsuite/tests/determinism/determ009/determ009.stdout2
-rw-r--r--testsuite/tests/determinism/determ011/A.hs26
-rw-r--r--testsuite/tests/determinism/determ011/Makefile13
-rw-r--r--testsuite/tests/determinism/determ011/all.T4
-rw-r--r--testsuite/tests/determinism/determ011/determ011.stdout2
-rw-r--r--testsuite/tests/determinism/determ012/A.hs10
-rw-r--r--testsuite/tests/determinism/determ012/Makefile13
-rw-r--r--testsuite/tests/determinism/determ012/all.T4
-rw-r--r--testsuite/tests/determinism/determ012/determ012.stdout2
-rw-r--r--testsuite/tests/determinism/determ013/A.hs19
-rw-r--r--testsuite/tests/determinism/determ013/Makefile13
-rw-r--r--testsuite/tests/determinism/determ013/all.T4
-rw-r--r--testsuite/tests/determinism/determ013/determ013.stdout2
-rw-r--r--testsuite/tests/determinism/determ014/A.hs38
-rw-r--r--testsuite/tests/determinism/determ014/Makefile13
-rw-r--r--testsuite/tests/determinism/determ014/all.T4
-rw-r--r--testsuite/tests/determinism/determ014/determ014.stdout2
-rw-r--r--testsuite/tests/determinism/determ015/A.hs59
-rw-r--r--testsuite/tests/determinism/determ015/Makefile13
-rw-r--r--testsuite/tests/determinism/determ015/all.T4
-rw-r--r--testsuite/tests/determinism/determ015/determ015.stdout2
-rw-r--r--testsuite/tests/determinism/determ016/A.hs19
-rw-r--r--testsuite/tests/determinism/determ016/Makefile13
-rw-r--r--testsuite/tests/determinism/determ016/all.T4
-rw-r--r--testsuite/tests/determinism/determ016/determ016.stdout2
-rw-r--r--testsuite/tests/determinism/determ017/A.hs215
-rw-r--r--testsuite/tests/determinism/determ017/Makefile13
-rw-r--r--testsuite/tests/determinism/determ017/all.T4
-rw-r--r--testsuite/tests/determinism/determ017/determ017.stdout2
41 files changed, 596 insertions, 0 deletions
diff --git a/testsuite/driver/extra_files.py b/testsuite/driver/extra_files.py
index 3d38fcfe0e..960b1df38b 100644
--- a/testsuite/driver/extra_files.py
+++ b/testsuite/driver/extra_files.py
@@ -188,7 +188,17 @@ extra_src_files = {
'determ003': ['A.hs'],
'determ005': ['A.hs'],
'determ006': ['spec-inline-determ.hs'],
+ 'determ007': ['A.hs'],
+ 'determ008': ['A.hs'],
+ 'determ009': ['A.hs'],
'determ010': ['A.hs'],
+ 'determ011': ['A.hs'],
+ 'determ012': ['A.hs'],
+ 'determ013': ['A.hs'],
+ 'determ014': ['A.hs'],
+ 'determ015': ['A.hs'],
+ 'determ016': ['A.hs'],
+ 'determ017': ['A.hs'],
'determ018': ['A.hs'],
'determ019': ['A.hs'],
'dodgy': ['DodgyA.hs'],
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 )