More demand analyser test cases

catching mistakes that I had during my refactoring, and which I do not
want to do again.

7 files changed, 84 insertions, 3 deletions

diff --git a/testsuite/tests/stranal/sigs/BottomFromInnerLambda.hs b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.hs
new file mode 100644
index 0000000000..8d3b77f832
--- /dev/null
+++ b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.hs
@@ -0,0 +1,12 @@
+module BottomFromInnerLambda where
+
+expensive :: Int -> Int
+expensive 0 = 0
+expensive n = expensive n
+{-# NOINLINE expensive #-}
+
+-- We could be saying "<S(S),1*(U(U))><L,A>b"
+-- but we are saying "<S(S),1*(U(U))>"
+-- We should not be saying "<S(S),1*(U(U))>b"
+f :: Int -> Int -> Int
+f x = expensive x `seq` (\y -> error (show y))
diff --git a/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr
new file mode 100644
index 0000000000..e8ae690147
--- /dev/null
+++ b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr
@@ -0,0 +1,6 @@
+
+==================== Strictness signatures ====================
+BottomFromInnerLambda.expensive: <S(S),1*U(U)>m
+BottomFromInnerLambda.f: <S(S),1*U(U)>
+
+
diff --git a/testsuite/tests/stranal/sigs/DmdAnalGADTs.hs b/testsuite/tests/stranal/sigs/DmdAnalGADTs.hs
new file mode 100644
index 0000000000..de6484fefd
--- /dev/null
+++ b/testsuite/tests/stranal/sigs/DmdAnalGADTs.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE GADTs #-}
+module DmdAnalGADTs where
+
+-- This tests the effect of different types in branches of a case
+
+data D a where
+    A :: D Int
+    B :: D (Int -> Int)
+
+hasCPR :: Int
+hasCPR = 1
+
+hasStrSig :: Int -> Int
+hasStrSig x = x
+
+diverges :: Int
+diverges = diverges
+
+-- The result should not have a CPR property
+-- Becuase we are lub’ing "m" and "<S,U>m" in the case expression.
+f :: D x -> x
+f x = case x of
+    A -> hasCPR
+    B -> hasStrSig
+
+-- This should have the CPR property
+f' :: D Int -> Int
+f' x = case x of
+    A -> hasCPR
+
+-- The result should not be diverging, because one branch is terminating.
+-- It should also put a strict, but not hyperstrict demand on x
+g :: D x -> x
+g x = case x of
+    A -> diverges
+    B -> \_ -> diverges
+
+
diff --git a/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr b/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr
new file mode 100644
index 0000000000..7fb1a55223
--- /dev/null
+++ b/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr
@@ -0,0 +1,10 @@
+
+==================== Strictness signatures ====================
+DmdAnalGADTs.diverges: b
+DmdAnalGADTs.f: <S,1*U>
+DmdAnalGADTs.f': <S,1*U>m
+DmdAnalGADTs.g: <S,1*U>
+DmdAnalGADTs.hasCPR: m
+DmdAnalGADTs.hasStrSig: <S,1*U(U)>m
+
+
diff --git a/testsuite/tests/stranal/sigs/UnsatFun.hs b/testsuite/tests/stranal/sigs/UnsatFun.hs
index 23ba6426cd..c38c5cba1d 100644
--- a/testsuite/tests/stranal/sigs/UnsatFun.hs
+++ b/testsuite/tests/stranal/sigs/UnsatFun.hs
@@ -24,6 +24,17 @@ g :: Int -> Int
 g x = let f' = f x
       in h f'
 
-g2 :: Int -> Int
-g2 x = let f' = f x
+-- Should not get a bottom result
+g' :: Int -> Int
+g' x = let f' = f x
        in h2 True f'
+
+h3 :: (Int -> Int -> Int) -> Int
+h3 f = f 2 `seq` 3
+{-# NOINLINE h3 #-}
+
+
+-- And here we check that the depth of the strictness
+-- of h is applied correctly.
+g3 :: Int -> Int
+g3 x = h3 (\_ _ -> error (show x))
diff --git a/testsuite/tests/stranal/sigs/UnsatFun.stderr b/testsuite/tests/stranal/sigs/UnsatFun.stderr
index 3d95c44d81..6e6402bacc 100644
--- a/testsuite/tests/stranal/sigs/UnsatFun.stderr
+++ b/testsuite/tests/stranal/sigs/UnsatFun.stderr
@@ -2,8 +2,10 @@
 ==================== Strictness signatures ====================
 UnsatFun.f: <B,1*U(U)><B,A>b
 UnsatFun.g: <B,1*U(U)>b
-UnsatFun.g2: <L,1*U(U)>
+UnsatFun.g': <L,1*U(U)>
+UnsatFun.g3: <L,U(U)>m
 UnsatFun.h: <C(S),1*C1(U(U))>
 UnsatFun.h2: <S,1*U><L,1*C1(U(U))>
+UnsatFun.h3: <C(S),1*C1(U)>m
 
 
diff --git a/testsuite/tests/stranal/sigs/all.T b/testsuite/tests/stranal/sigs/all.T
index 3657432cdf..9d36479c17 100644
--- a/testsuite/tests/stranal/sigs/all.T
+++ b/testsuite/tests/stranal/sigs/all.T
@@ -13,3 +13,5 @@ test('HyperStrUse', normal, compile, [''])
 test('T8598', normal, compile, [''])
 test('FacState', expect_broken(1600), compile, [''])
 test('UnsatFun', normal, compile, [''])
+test('BottomFromInnerLambda', normal, compile, [''])
+test('DmdAnalGADTs', normal, compile, [''])