diff options
Diffstat (limited to 'testsuite')
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 ) |