[commit: packages/stm] master: Add testcase for #14171 (b6e863e)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/stm

On branch  : master
Link       : http://git.haskell.org/packages/stm.git/commitdiff/b6e863e517bdcc3c5de1fbcb776a3fd7e6fe2103

>---------------------------------------------------------------

commit b6e863e517bdcc3c5de1fbcb776a3fd7e6fe2103
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Thu Aug 31 16:03:28 2017 -0400

    Add testcase for #14171


>---------------------------------------------------------------

b6e863e517bdcc3c5de1fbcb776a3fd7e6fe2103
 tests/T14171.hs     | 38 ++++++++++++++++++++++++++++++++++++++
 tests/T14171.stderr |  1 +
 tests/all.T         |  2 +-
 3 files changed, 40 insertions(+), 1 deletion(-)

diff --git a/tests/T14171.hs b/tests/T14171.hs
new file mode 100644
index 0000000..d9a32b7
--- /dev/null
+++ b/tests/T14171.hs
@@ -0,0 +1,38 @@
+module Main where
+
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TVar
+
+data A = A String deriving (Eq, Show)
+
+data E = E {
+  a :: TVar [Int],
+  b :: TVar A,
+  c :: TVar [Int]
+  }
+
+consistency_1 :: E -> STM Bool
+consistency_1 = \e -> do
+  _ <- readTVar $ c e
+  return True
+
+installSanityChecks :: E -> IO ()
+installSanityChecks e = do
+  x e
+  fail "You should see this failure"
+
+x :: E -> IO ()
+x e = do
+  -- This unexpected succeeds
+  atomically $ installCheck consistency_1
+  -- error "derp2"
+  where
+    installCheck check = always $ check e
+
+main :: IO ()
+main = do
+  state <- initialize
+  installSanityChecks state
+
+initialize :: IO E
+initialize = E <$> newTVarIO [] <*> newTVarIO (A "USD") <*> newTVarIO []
diff --git a/tests/T14171.stderr b/tests/T14171.stderr
new file mode 100644
index 0000000..84de5c7
--- /dev/null
+++ b/tests/T14171.stderr
@@ -0,0 +1 @@
+T14171: user error (You should see this failure)
diff --git a/tests/all.T b/tests/all.T
index 213ea75..c2ea89e 100644
--- a/tests/all.T
+++ b/tests/all.T
@@ -28,5 +28,5 @@ test('T3049', normal, compile_and_run, ['-package stm'])
 test('T4057', normal, compile_and_run, ['-package stm'])
 test('stm064', normal, compile_and_run, ['-package stm'])
 test('stm065', normal, compile_and_run, ['-package stm'])
-
 test('cloneTChan001', normal, compile_and_run, ['-package stm'])
+test('T14171', exit_code(1), compile_and_run, ['-package stm'])